Merge remote-tracking branch 'origin/topic/projects' into cp/project-codebase-browse

CONTRIBUTORS.markdown

@@ -73,3 +73,4 @@ The format for this list: name, GitHub handle
 * Jesse Looney (@jesselooney)
 * Vlad Posmangiu Luchian (@cstml)
 * Andrii Uvarov (@unorsk)
+* Mario Bašić (@mabasic)

README.md

@@ -42,7 +42,7 @@ If these instructions don't work for you or are incomplete, please file an issue
 
 The build uses [Stack](http://docs.haskellstack.org/). If you don't already have it installed, [follow the install instructions](http://docs.haskellstack.org/en/stable/README.html#how-to-install) for your platform.  (Hint: `brew update && brew install stack`)
 
-If you have not set up the Haskell toolchain before and are trying to contribute to Unison on an M1 Mac, we have [some tips specifically for you](docs/m1-mac-setup-tips.markdown/new).
+If you have not set up the Haskell toolchain before and are trying to contribute to Unison on an M1 Mac, we have [some tips specifically for you](docs/m1-mac-setup-tips.markdown).
 
 ```sh
 $ git clone https://github.com/unisonweb/unison.git

codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs

@@ -322,6 +322,8 @@ import U.Codebase.WatchKind (WatchKind)
 import qualified U.Core.ABT as ABT
 import qualified U.Util.Serialization as S
 import qualified U.Util.Term as TermUtil
+import Unison.Core.Orphans.Sqlite ()
+import Unison.Core.Project (ProjectBranchName, ProjectName)
 import Unison.Hash (Hash)
 import qualified Unison.Hash as Hash
 import Unison.Hash32 (Hash32)
@@ -2484,7 +2486,7 @@ getReflog numEntries = queryListRow sql (Only numEntries)
 
 data Project = Project
   { projectId :: ProjectId,
-    name :: Text
+    name :: ProjectName
   }
   deriving stock (Generic, Show)
   deriving anyclass (ToRow, FromRow)
@@ -2492,7 +2494,7 @@ data Project = Project
 data RemoteProject = RemoteProject
   { projectId :: RemoteProjectId,
     host :: URI,
-    name :: Text
+    name :: ProjectName
   }
   deriving stock (Generic, Show)
   deriving anyclass (ToRow, FromRow)
@@ -2500,7 +2502,7 @@ data RemoteProject = RemoteProject
 data Branch = Branch
   { projectId :: ProjectId,
     branchId :: ProjectBranchId,
-    name :: Text
+    name :: ProjectBranchName
   }
   deriving stock (Generic, Show)
   deriving anyclass (ToRow, FromRow)
@@ -2509,7 +2511,7 @@ data RemoteProjectBranch = RemoteProjectBranch
   { projectId :: RemoteProjectId,
     branchId :: RemoteProjectBranchId,
     host :: URI,
-    name :: Text
+    name :: ProjectBranchName
   }
   deriving stock (Generic, Show)
   deriving anyclass (ToRow, FromRow)
@@ -2528,7 +2530,7 @@ projectExists projectId =
     (Only projectId)
 
 -- | Does a project exist by this name?
-projectExistsByName :: Text -> Transaction Bool
+projectExistsByName :: ProjectName -> Transaction Bool
 projectExistsByName name =
   queryOneCol
     [sql|
@@ -2558,7 +2560,7 @@ loadProjectSql =
       id = ?
   |]
 
-loadProjectByName :: Text -> Transaction (Maybe Project)
+loadProjectByName :: ProjectName -> Transaction (Maybe Project)
 loadProjectByName name =
   queryMaybeRow
     [sql|
@@ -2572,17 +2574,18 @@ loadProjectByName name =
     |]
     (Only name)
 
-insertProject :: ProjectId -> Text -> Transaction ()
+-- | Insert a `project` row.
+insertProject :: ProjectId -> ProjectName -> Transaction ()
 insertProject uuid name = execute bonk (uuid, name)
   where
     bonk =
       [sql|
         INSERT INTO project (id, name)
           VALUES (?, ?)
-           |]
+      |]
 
 -- | Does a project branch exist by this name?
-projectBranchExistsByName :: ProjectId -> Text -> Transaction Bool
+projectBranchExistsByName :: ProjectId -> ProjectBranchName -> Transaction Bool
 projectBranchExistsByName projectId name =
   queryOneCol
     [sql|
@@ -2620,7 +2623,7 @@ loadProjectBranchSql =
       AND branch_id = ?
   |]
 
-loadProjectBranchByName :: ProjectId -> Text -> Transaction (Maybe Branch)
+loadProjectBranchByName :: ProjectId -> ProjectBranchName -> Transaction (Maybe Branch)
 loadProjectBranchByName projectId name =
   queryMaybeRow
     [sql|
@@ -2636,7 +2639,7 @@ loadProjectBranchByName projectId name =
     |]
     (projectId, name)
 
-loadProjectAndBranchNames :: ProjectId -> ProjectBranchId -> Transaction (Maybe (Text, Text))
+loadProjectAndBranchNames :: ProjectId -> ProjectBranchId -> Transaction (Maybe (ProjectName, ProjectBranchName))
 loadProjectAndBranchNames projectId branchId =
   queryMaybeRow
     [sql|
@@ -2652,7 +2655,8 @@ loadProjectAndBranchNames projectId branchId =
     |]
     (projectId, branchId)
 
-insertProjectBranch :: ProjectId -> ProjectBranchId -> Text -> Transaction ()
+-- | Insert a `project_branch` row.
+insertProjectBranch :: ProjectId -> ProjectBranchId -> ProjectBranchName -> Transaction ()
 insertProjectBranch pid bid bname = execute bonk (pid, bid, bname)
   where
     bonk =
@@ -2797,7 +2801,7 @@ loadRemoteProject rpid host =
     |]
     (rpid, host)
 
-ensureRemoteProject :: RemoteProjectId -> URI -> Text -> Transaction ()
+ensureRemoteProject :: RemoteProjectId -> URI -> ProjectName -> Transaction ()
 ensureRemoteProject rpid host name =
   execute
     [sql|
@@ -2817,7 +2821,7 @@ ensureRemoteProject rpid host name =
         |]
     (rpid, host, name)
 
-expectRemoteProjectName :: RemoteProjectId -> URI -> Transaction Text
+expectRemoteProjectName :: RemoteProjectId -> URI -> Transaction ProjectName
 expectRemoteProjectName projectId host =
   queryOneCol
     [sql|
@@ -2831,7 +2835,7 @@ expectRemoteProjectName projectId host =
     |]
     (projectId, host)
 
-setRemoteProjectName :: RemoteProjectId -> Text -> Transaction ()
+setRemoteProjectName :: RemoteProjectId -> ProjectName -> Transaction ()
 setRemoteProjectName rpid name =
   execute
     [sql|
@@ -2862,7 +2866,7 @@ loadRemoteBranch rpid host rbid =
     |]
     (rpid, rbid, host)
 
-ensureRemoteProjectBranch :: RemoteProjectId -> URI -> RemoteProjectBranchId -> Text -> Transaction ()
+ensureRemoteProjectBranch :: RemoteProjectId -> URI -> RemoteProjectBranchId -> ProjectBranchName -> Transaction ()
 ensureRemoteProjectBranch rpid host rbid name =
   execute
     [sql|
@@ -2885,7 +2889,7 @@ ensureRemoteProjectBranch rpid host rbid name =
         |]
     (rpid, host, rbid, name)
 
-expectRemoteProjectBranchName :: URI -> RemoteProjectId -> RemoteProjectBranchId -> Transaction Text
+expectRemoteProjectBranchName :: URI -> RemoteProjectId -> RemoteProjectBranchId -> Transaction ProjectBranchName
 expectRemoteProjectBranchName host projectId branchId =
   queryOneCol
     [sql|
@@ -2900,7 +2904,7 @@ expectRemoteProjectBranchName host projectId branchId =
     |]
     (host, projectId, branchId)
 
-setRemoteProjectBranchName :: RemoteProjectId -> URI -> RemoteProjectBranchId -> Text -> Transaction ()
+setRemoteProjectBranchName :: RemoteProjectId -> URI -> RemoteProjectBranchId -> ProjectBranchName -> Transaction ()
 setRemoteProjectBranchName rpid host rbid name =
   execute
     [sql|

codebase2/codebase-sqlite/package.yaml

@@ -32,6 +32,7 @@ dependencies:
   - unison-codebase
   - unison-codebase-sync
   - unison-core
+  - unison-core-orphans-sqlite
   - unison-hash
   - unison-hash-orphans-sqlite
   - unison-prelude

codebase2/codebase-sqlite/unison-codebase-sqlite.cabal

@@ -110,6 +110,7 @@ library
     , unison-codebase
     , unison-codebase-sync
     , unison-core
+    , unison-core-orphans-sqlite
     , unison-hash
     , unison-hash-orphans-sqlite
     , unison-prelude

codebase2/core/Unison/Core/Project.hs

@@ -0,0 +1,30 @@
+-- | Project-related types.
+--
+-- A larger API, including orphan instances for parsing from 'Text', is available in "Unison.Project". Here, we just
+-- define the types, which are shared among the low-level database layer (which assumes without verifying that project
+-- names and such are syntactically valid) and the higher-level project manipulation exposed by UCM.
+module Unison.Core.Project
+  ( ProjectName (..),
+    ProjectBranchName (..),
+    ProjectAndBranch (..),
+  )
+where
+
+import Unison.Prelude
+
+-- | The name of a project.
+newtype ProjectName
+  = UnsafeProjectName Text
+  deriving stock (Eq, Ord, Show)
+
+-- | The name of a branch of a project.
+newtype ProjectBranchName
+  = ProjectBranchName Text
+  deriving stock (Eq, Ord, Show)
+
+-- | A generic data structure that contains information about a project and a branch in that project.
+data ProjectAndBranch a b = ProjectAndBranch
+  { project :: a,
+    branch :: b
+  }
+  deriving stock (Eq, Generic, Show)

codebase2/core/unison-core.cabal

@@ -19,6 +19,7 @@ library
       U.Codebase.HashTags
       U.Core.ABT
       U.Core.ABT.Var
+      Unison.Core.Project
       Unison.NameSegment
       Unison.Util.Alphabetical
   hs-source-dirs:

docs/language-server.markdown

@@ -79,6 +79,26 @@ Note that you'll need to start UCM _before_ you try connecting to it in your edi
 
 Simply install the [Unison Language VSCode extension](https://marketplace.visualstudio.com/items?itemName=unison-lang.unison).
 
+### Helix Editor
+
+To `~/.config/helix/languages.toml` append this code:
+
+```toml
+[[language]]
+name = "unison"
+scope = "source.unison"
+injection-regex = "unison"
+file-types = ["u"]
+shebangs = []
+roots = []
+auto-format = false
+comment-token = "--"
+indent = { tab-width = 4, unit = "    " }
+language-server = { command = "ncat", args = ["localhost", "5757"] }
+```
+
+or follow the instructions for Unison in "[How to install the default language servers](https://github.com/helix-editor/helix/wiki/How-to-install-the-default-language-servers#unison)" wiki page.
+
 
 ### Other Editors
 

hie.yaml

@@ -21,13 +21,16 @@ cradle:
     - path: "codebase2/util-term/./"
       component: "unison-util-term:lib"
 
+    - path: "lib/orphans/unison-core-orphans-sqlite/src"
+      component: "unison-core-orphans-sqlite:lib"
+
     - path: "lib/unison-hash/src"
       component: "unison-hash:lib"
 
-    - path: "lib/unison-hash-orphans-aeson/src"
+    - path: "lib/orphans/unison-hash-orphans-aeson/src"
       component: "unison-hash-orphans-aeson:lib"
 
-    - path: "lib/unison-hash-orphans-sqlite/src"
+    - path: "lib/orphans/unison-hash-orphans-sqlite/src"
       component: "unison-hash-orphans-sqlite:lib"
 
     - path: "lib/unison-hashing/src"
@@ -75,7 +78,7 @@ cradle:
     - path: "lib/unison-util-rope/src"
       component: "unison-util-rope:lib"
 
-    - path: "lib/uuid-orphans-sqlite/src"
+    - path: "lib/orphans/uuid-orphans-sqlite/src"
       component: "uuid-orphans-sqlite:lib"
 
     - path: "parser-typechecker/src"

lib/orphans/README.md

@@ -0,0 +1,14 @@
+Canonical orphans packages.
+
+The package name template is
+
+```
+<package-providing-type>-orphans-<package-providing-typeclass>
+```
+
+(with some flexibility as to what exactly `<package-providing-typeclass>` is called; for example, although we are 
+currently using the `sqlite-simple` package, we call suffix sqlite orphan packages with `-sqlite`, not `-sqlite-simple`,
+for no great reason other than aesthetics).
+
+For example, the package that defines `To/FromField` instances (from `sqlite-simple`) for types defined in `unison-core`
+is called `unison-core-orphans-sqlite`.

lib/orphans/unison-core-orphans-sqlite/package.yaml

@@ -0,0 +1,43 @@
+name: unison-core-orphans-sqlite
+github: unisonweb/unison
+copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors
+
+library:
+  when:
+    - condition: false
+      other-modules: Paths_unison_core_orphans_sqlite
+  source-dirs: src
+
+dependencies:
+  - base
+  - sqlite-simple
+  - text
+  - unison-core
+
+ghc-options:
+  -Wall
+
+default-extensions:
+  - ApplicativeDo
+  - BangPatterns
+  - BlockArguments
+  - DeriveFunctor
+  - DeriveGeneric
+  - DeriveTraversable
+  - DerivingStrategies
+  - DerivingVia
+  - DoAndIfThenElse
+  - FlexibleContexts
+  - FlexibleInstances
+  - GeneralizedNewtypeDeriving
+  - LambdaCase
+  - MultiParamTypeClasses
+  - NamedFieldPuns
+  - OverloadedStrings
+  - PatternSynonyms
+  - RankNTypes
+  - ScopedTypeVariables
+  - StandaloneDeriving
+  - TupleSections
+  - TypeApplications
+  - ViewPatterns

lib/orphans/unison-core-orphans-sqlite/src/Unison/Core/Orphans/Sqlite.hs

@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Unison.Core.Orphans.Sqlite () where
+
+import Data.Text (Text)
+import Database.SQLite.Simple.FromField (FromField)
+import Database.SQLite.Simple.ToField (ToField)
+import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
+
+deriving via Text instance ToField ProjectName
+
+deriving via Text instance FromField ProjectName
+
+deriving via Text instance ToField ProjectBranchName
+
+deriving via Text instance FromField ProjectBranchName

lib/orphans/unison-core-orphans-sqlite/unison-core-orphans-sqlite.cabal

@@ -0,0 +1,53 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.35.0.
+--
+-- see: https://github.com/sol/hpack
+
+name:           unison-core-orphans-sqlite
+version:        0.0.0
+homepage:       https://github.com/unisonweb/unison#readme
+bug-reports:    https://github.com/unisonweb/unison/issues
+copyright:      Copyright (C) 2013-2021 Unison Computing, PBC and contributors
+build-type:     Simple
+
+source-repository head
+  type: git
+  location: https://github.com/unisonweb/unison
+
+library
+  exposed-modules:
+      Unison.Core.Orphans.Sqlite
+  hs-source-dirs:
+      src
+  default-extensions:
+      ApplicativeDo
+      BangPatterns
+      BlockArguments
+      DeriveFunctor
+      DeriveGeneric
+      DeriveTraversable
+      DerivingStrategies
+      DerivingVia
+      DoAndIfThenElse
+      FlexibleContexts
+      FlexibleInstances
+      GeneralizedNewtypeDeriving
+      LambdaCase
+      MultiParamTypeClasses
+      NamedFieldPuns
+      OverloadedStrings
+      PatternSynonyms
+      RankNTypes
+      ScopedTypeVariables
+      StandaloneDeriving
+      TupleSections
+      TypeApplications
+      ViewPatterns
+  ghc-options: -Wall
+  build-depends:
+      base
+    , sqlite-simple
+    , text
+    , unison-core
+  default-language: Haskell2010

lib/unison-prelude/src/Unison/Debug.hs

@@ -39,6 +39,8 @@ data DebugFlag
     Temp
   | -- | Shows Annotations when printing terms
     Annotations
+  | PatternCoverage
+  | PatternCoverageConstraintSolver
   deriving (Eq, Ord, Show, Bounded, Enum)
 
 debugFlags :: Set DebugFlag
@@ -61,6 +63,8 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of
       "TIMING" -> pure Timing
       "TEMP" -> pure Temp
       "ANNOTATIONS" -> pure Annotations
+      "PATTERN_COVERAGE" -> pure PatternCoverage
+      "PATTERN_COVERAGE_CONSTRAINT_SOLVER" -> pure PatternCoverageConstraintSolver
       _ -> empty
 {-# NOINLINE debugFlags #-}
 
@@ -108,6 +112,14 @@ debugAnnotations :: Bool
 debugAnnotations = Annotations `Set.member` debugFlags
 {-# NOINLINE debugAnnotations #-}
 
+debugPatternCoverage :: Bool
+debugPatternCoverage = PatternCoverage `Set.member` debugFlags
+{-# NOINLINE debugPatternCoverage #-}
+
+debugPatternCoverageConstraintSolver :: Bool
+debugPatternCoverageConstraintSolver = PatternCoverageConstraintSolver `Set.member` debugFlags
+{-# NOINLINE debugPatternCoverageConstraintSolver #-}
+
 -- | Use for trace-style selective debugging.
 -- E.g. 1 + (debug Git "The second number" 2)
 --
@@ -159,3 +171,5 @@ shouldDebug = \case
   Timing -> debugTiming
   Temp -> debugTemp
   Annotations -> debugAnnotations
+  PatternCoverage -> debugPatternCoverage
+  PatternCoverageConstraintSolver -> debugPatternCoverageConstraintSolver

parser-typechecker/src/Unison/Codebase.hs

@@ -162,6 +162,7 @@ import Unison.Symbol (Symbol)
 import Unison.Term (Term)
 import qualified Unison.Term as Term
 import Unison.Type (Type)
+import qualified Unison.Type as Type
 import Unison.Typechecker.TypeLookup (TypeLookup (TypeLookup))
 import qualified Unison.Typechecker.TypeLookup as TL
 import qualified Unison.UnisonFile as UF
@@ -347,26 +348,45 @@ lookupWatchCache codebase h = do
   maybe (getWatch codebase WK.TestWatch h) (pure . Just) m1
 
 typeLookupForDependencies ::
+  forall m a.
   (BuiltinAnnotation a) =>
   Codebase m Symbol a ->
   Set Reference ->
   Sqlite.Transaction (TL.TypeLookup Symbol a)
 typeLookupForDependencies codebase s = do
   when debug $ traceM $ "typeLookupForDependencies " ++ show s
-  foldM go mempty s
+  depthFirstAccum mempty s
   where
+    depthFirstAccum :: TL.TypeLookup Symbol a -> Set Reference -> Sqlite.Transaction (TL.TypeLookup Symbol a)
+    depthFirstAccum tl refs = foldM go tl (Set.filter (unseen tl) refs)
+
+    -- We need the transitive dependencies of data decls
+    -- that are scrutinized in a match expression for
+    -- pattern match coverage checking (specifically for
+    -- the inhabitation check). We ensure these are found
+    -- by collecting all transitive type dependencies.
     go tl ref@(Reference.DerivedId id) =
-      fmap (tl <>) $
-        getTypeOfTerm codebase ref >>= \case
-          Just typ -> pure $ TypeLookup (Map.singleton ref typ) mempty mempty
-          Nothing ->
-            getTypeDeclaration codebase id >>= \case
-              Just (Left ed) ->
-                pure $ TypeLookup mempty mempty (Map.singleton ref ed)
-              Just (Right dd) ->
-                pure $ TypeLookup mempty (Map.singleton ref dd) mempty
-              Nothing -> pure mempty
+      getTypeOfTerm codebase ref >>= \case
+        Just typ ->
+          let z = tl <> TypeLookup (Map.singleton ref typ) mempty mempty
+           in depthFirstAccum z (Type.dependencies typ)
+        Nothing ->
+          getTypeDeclaration codebase id >>= \case
+            Just (Left ed) ->
+              let z = tl <> TypeLookup mempty mempty (Map.singleton ref ed)
+               in depthFirstAccum z (DD.dependencies $ DD.toDataDecl ed)
+            Just (Right dd) ->
+              let z = tl <> TypeLookup mempty (Map.singleton ref dd) mempty
+               in depthFirstAccum z (DD.dependencies dd)
+            Nothing -> pure tl
     go tl Reference.Builtin {} = pure tl -- codebase isn't consulted for builtins
+    unseen :: TL.TypeLookup Symbol a -> Reference -> Bool
+    unseen tl r =
+      isNothing
+        ( Map.lookup r (TL.dataDecls tl) $> ()
+            <|> Map.lookup r (TL.typeOfTerms tl) $> ()
+            <|> Map.lookup r (TL.effectDecls tl) $> ()
+        )
 
 toCodeLookup :: (MonadIO m) => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann
 toCodeLookup c =

parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs

@@ -63,7 +63,7 @@ writeToReadGit :: WriteGitRepo -> ReadGitRepo
 writeToReadGit = \case
   WriteGitRepo {url, branch} -> ReadGitRepo {url = url, ref = branch}
 
-writePathToRead :: WriteRemotePath -> ReadRemoteNamespace
+writePathToRead :: WriteRemotePath -> ReadRemoteNamespace void
 writePathToRead = \case
   WriteRemotePathGit WriteGitRemotePath {repo, path} ->
     ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo = writeToReadGit repo, sch = Nothing, path}
@@ -78,8 +78,8 @@ printWriteGitRepo :: WriteGitRepo -> Text
 printWriteGitRepo WriteGitRepo {url, branch} = "git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) <> ")"
 
 -- | print remote namespace
-printNamespace :: ReadRemoteNamespace -> Text
-printNamespace = \case
+printNamespace :: (a -> Text) -> ReadRemoteNamespace a -> Text
+printNamespace printProject = \case
   ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sch, path} ->
     printReadGitRepo repo <> maybePrintSCH sch <> maybePrintPath path
     where
@@ -88,6 +88,7 @@ printNamespace = \case
         Just sch -> "#" <> SCH.toText sch
   ReadRemoteNamespaceShare ReadShareRemoteNamespace {server, repo, path} ->
     displayShareCodeserver server repo path
+  ReadRemoteProjectBranch project -> printProject project
 
 -- | Render a 'WriteRemotePath' as text.
 printWriteRemotePath :: WriteRemotePath -> Text
@@ -103,10 +104,13 @@ maybePrintPath path =
     then mempty
     else "." <> Path.toText path
 
-data ReadRemoteNamespace
+data ReadRemoteNamespace a
   = ReadRemoteNamespaceGit ReadGitRemoteNamespace
   | ReadRemoteNamespaceShare ReadShareRemoteNamespace
-  deriving stock (Eq, Show)
+  | -- | 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.
+    ReadRemoteProjectBranch a
+  deriving stock (Eq, Show, Generic)
 
 data ReadGitRemoteNamespace = ReadGitRemoteNamespace
   { repo :: ReadGitRepo,

parser-typechecker/src/Unison/PatternMatchCoverage.hs

@@ -0,0 +1,82 @@
+-- | Pattern match coverage checking is implemented following the
+-- algorithm described in [Lower Your
+-- Guards](https://simon.peytonjones.org/assets/pdfs/lower-your-guards.pdf). The
+-- goal of pattern match coverage checking is to identify the
+-- following problems that may arise in a pattern match:
+--
+-- * It is missing clauses (/i.e./ it is non-exhaustive)
+-- * It contains redundant patterns (/i.e./ the case can be deleted without altering the program)
+-- * It contains inaccessible patterns (/i.e/ the rhs can never be entered)
+--
+-- Furthermore, in the case of a non-exhaustive match, the goal to
+-- present the user with concrete values that do not match any of the
+-- existing patterns.
+--
+-- /N.B./ An inaccessible pattern in unison would be one that performs
+-- effects in a guard although the constraints are unsatisfiable. Such
+-- a pattern cannot be deleted without altering the program.
+--
+-- == High-level algorithm overview
+--
+-- 1. [Desugar]("Unison.PatternMatchCoverage.Desugar") a match expression into a 'Unison.PatternMatchCoverage.GrdTree.GrdTree'.
+-- 2. Annotate the @GrdTree@ leaves with [refinement types]("Unison.PatternMatchCoverage.NormalizedConstraints")
+-- describing values that match this branch. Redundant and inaccessible patterns are then identified by @GrdTree@ leaves
+-- with uninhabited refinement types. Inaccessible patterns are distinguished by an effect being performed between the
+-- @GrdTree@ root and the leaf.
+-- 3. Traverse the @GrdTree@ building up a refinement type describing uncovered values. If the resulting refinement type
+-- is inhabited then the match is missing clauses.
+-- 4. Find inhabitants of the uncovered refinement type to present to the user.
+--
+-- Step (1) is implemented by 'desugarMatch'. Steps (2) and (3) are
+-- implemented as a single traversal: 'uncoverAnnotate'/'classify'. Step (4) is
+-- implemented by 'expandSolution'/'generateInhabitants'.
+module Unison.PatternMatchCoverage
+  ( checkMatch,
+  )
+where
+
+import qualified Data.Set as Set
+import Debug.Trace
+import Unison.Debug
+import Unison.Pattern (Pattern)
+import Unison.PatternMatchCoverage.Class (Pmc (..))
+import Unison.PatternMatchCoverage.Desugar (desugarMatch)
+import Unison.PatternMatchCoverage.GrdTree (prettyGrdTree)
+import qualified Unison.PatternMatchCoverage.NormalizedConstraints as NC
+import Unison.PatternMatchCoverage.PmGrd (prettyPmGrd)
+import Unison.PatternMatchCoverage.Solve (classify, expandSolution, generateInhabitants, uncoverAnnotate)
+import qualified Unison.Term as Term
+import qualified Unison.Type as Type
+import qualified Unison.Util.Pretty as P
+
+-- | Perform pattern match coverage checking on a match expression
+checkMatch ::
+  forall vt v loc m.
+  (Pmc vt v loc m) =>
+  -- | the match location
+  loc ->
+  -- | scrutinee type
+  Type.Type vt loc ->
+  -- | match cases
+  [Term.MatchCase loc (Term.Term' vt v loc)] ->
+  -- | (redundant locations, inaccessible locations, inhabitants of uncovered refinement type)
+  m ([loc], [loc], [Pattern ()])
+checkMatch matchLocation scrutineeType cases = do
+  v0 <- fresh
+  grdtree0 <- desugarMatch matchLocation scrutineeType v0 cases
+  (uncovered, grdtree1) <- uncoverAnnotate (Set.singleton (NC.markDirty v0 $ NC.declVar v0 scrutineeType id NC.emptyNormalizedConstraints)) grdtree0
+  uncoveredExpanded <- concat . fmap Set.toList <$> traverse (expandSolution v0) (Set.toList uncovered)
+  let sols = map (generateInhabitants v0) uncoveredExpanded
+  let (_accessible, inaccessible, redundant) = classify grdtree1
+  let debugOutput =
+        P.sep
+          "\n"
+          [ P.hang "desugared:" (prettyGrdTree prettyPmGrd (\_ -> "<loc>") grdtree0),
+            P.hang "annotated:" (prettyGrdTree NC.prettyDnf (NC.prettyDnf . fst) grdtree1),
+            P.hang "uncovered:" (NC.prettyDnf uncovered),
+            P.hang "uncovered expanded:" (NC.prettyDnf (Set.fromList uncoveredExpanded))
+          ]
+      doDebug = case shouldDebug PatternCoverage of
+        True -> trace (P.toPlainUnbroken debugOutput)
+        False -> id
+  doDebug (pure (redundant, inaccessible, sols))

parser-typechecker/src/Unison/PatternMatchCoverage/Class.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE FunctionalDependencies #-}
+
+module Unison.PatternMatchCoverage.Class
+  ( Pmc (..),
+    EnumeratedConstructors (..),
+    traverseConstructors,
+  )
+where
+
+import Control.Monad.Fix (MonadFix)
+import Unison.ConstructorReference (ConstructorReference)
+import Unison.PatternMatchCoverage.ListPat (ListPat)
+import Unison.Type (Type)
+import Unison.Var (Var)
+
+-- | A typeclass for the queries required to perform pattern match
+-- coverage checking.
+class (Ord loc, Var vt, Var v, MonadFix m) => Pmc vt v loc m | m -> vt v loc where
+  -- | Get the constructors of a type
+  getConstructors :: Type vt loc -> m (EnumeratedConstructors vt v loc)
+
+  -- | Get the types of the arguments of a specific constructor
+  getConstructorVarTypes :: Type vt loc -> ConstructorReference -> m [Type vt loc]
+
+  -- | Get a fresh variable
+  fresh :: m v
+
+data EnumeratedConstructors vt v loc
+  = ConstructorType [(v, ConstructorReference, Type vt loc)]
+  | SequenceType [(ListPat, [Type vt loc])]
+  | BooleanType
+  | OtherType
+  deriving stock (Show)
+
+traverseConstructors ::
+  (Applicative f) =>
+  (v -> ConstructorReference -> Type vt loc -> f (v, ConstructorReference, Type vt loc)) ->
+  EnumeratedConstructors vt v loc ->
+  f (EnumeratedConstructors vt v loc)
+traverseConstructors f = \case
+  ConstructorType xs -> ConstructorType <$> traverse (\(a, b, c) -> f a b c) xs
+  SequenceType x -> pure (SequenceType x)
+  BooleanType -> pure BooleanType
+  OtherType -> pure OtherType

parser-typechecker/src/Unison/PatternMatchCoverage/Constraint.hs

@@ -0,0 +1,72 @@
+module Unison.PatternMatchCoverage.Constraint
+  ( Constraint (..),
+    prettyConstraint,
+  )
+where
+
+import Unison.ConstructorReference (ConstructorReference)
+import Unison.PatternMatchCoverage.IntervalSet (IntervalSet)
+import Unison.PatternMatchCoverage.PmLit
+import qualified Unison.PrettyPrintEnv as PPE
+import qualified Unison.Syntax.TypePrinter as TypePrinter
+import Unison.Type (Type)
+import Unison.Util.Pretty
+import Unison.Var (Var)
+
+-- | A constraint to add to a [normalized constraint
+-- set]("Unison.PatternMatchCoverage.NormalizedConstraints") (fig 6)
+-- See 'Unison.PatternMatchCoverage.Solve.addConstraint'
+data Constraint vt v loc
+  = -- | Positive constraint regarding data type. States that the
+    -- given variable must be the given constructor, and it also binds
+    -- variables corresponding to constructor arguments.
+    PosCon v ConstructorReference [(v, Type vt loc)]
+  | -- | Negative constraint concerning data type. States that the
+    -- given variable must not be the given constructor.
+    NegCon v ConstructorReference
+  | -- | Positive constraint regarding literal
+    PosLit v PmLit
+  | -- | Negative constraint regarding literal
+    NegLit v PmLit
+  | -- | Positive constraint on list element with position relative to head of list
+    PosListHead
+      v
+      -- ^ list root
+      Int
+      -- ^ cons position (0 is head)
+      v
+      -- ^ element variable
+  | -- | Positive constraint on list element with position relative to end of list
+    PosListTail
+      v
+      -- ^ list root
+      Int
+      -- ^ snoc position (0 is last)
+      v
+      -- ^ element variable
+  | -- | Negative constraint on length of the list (/i.e./ the list
+    -- may not be an element of the interval set)
+    NegListInterval v IntervalSet
+  | -- | An effect is performed
+    Effectful v
+  | -- | Equality constraint
+    Eq v v
+  deriving stock (Eq, Ord)
+
+prettyConstraint :: (Var vt, Var v) => Constraint vt v loc -> Pretty ColorText
+prettyConstraint = \case
+  PosCon var con convars ->
+    let xs = pc con : fmap (\(trm, typ) -> sep " " [pv trm, ":", TypePrinter.pretty PPE.empty typ]) convars ++ ["<-", pv var]
+     in sep " " xs
+  NegCon var con -> sep " " [pv var, "≠", pc con]
+  PosLit var lit -> sep " " [prettyPmLit lit, "<-", pv var]
+  NegLit var lit -> sep " " [pv var, "≠", prettyPmLit lit]
+  PosListHead root n el -> sep " " [pv el, "<-", "head", pc n, pv root]
+  PosListTail root n el -> sep " " [pv el, "<-", "tail", pc n, pv root]
+  NegListInterval var x -> sep " " [pv var, "≠", string (show x)]
+  Effectful var -> "!" <> pv var
+  Eq v0 v1 -> sep " " [pv v0, "=", pv v1]
+  where
+    pv = string . show
+    pc :: forall a. (Show a) => a -> Pretty ColorText
+    pc = string . show

parser-typechecker/src/Unison/PatternMatchCoverage/Desugar.hs

@@ -0,0 +1,210 @@
+module Unison.PatternMatchCoverage.Desugar
+  ( desugarMatch,
+  )
+where
+
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified U.Core.ABT as ABT
+import Unison.Pattern
+import qualified Unison.Pattern as Pattern
+import Unison.PatternMatchCoverage.Class
+import Unison.PatternMatchCoverage.Fix
+import Unison.PatternMatchCoverage.GrdTree
+import Unison.PatternMatchCoverage.PmGrd
+import qualified Unison.PatternMatchCoverage.PmLit as PmLit
+import Unison.Term (MatchCase (..), Term', app, var)
+import Unison.Type (Type)
+import qualified Unison.Type as Type
+
+-- | Desugar a match into a 'GrdTree'
+desugarMatch ::
+  forall loc vt v m.
+  (Pmc vt v loc m) =>
+  -- | loc of match
+  loc ->
+  -- | scrutinee type
+  Type vt loc ->
+  -- | scrutinee variable
+  v ->
+  -- | match cases
+  [MatchCase loc (Term' vt v loc)] ->
+  m (GrdTree (PmGrd vt v loc) loc)
+desugarMatch loc0 scrutineeType v0 cs0 =
+  traverse desugarClause cs0 >>= \case
+    [] -> pure $ Leaf loc0
+    x : xs -> pure $ Fork (x :| xs)
+  where
+    desugarClause :: MatchCase loc (Term' vt v loc) -> m (GrdTree (PmGrd vt v loc) loc)
+    desugarClause MatchCase {matchPattern, matchGuard} =
+      desugarPattern scrutineeType v0 matchPattern (finalK (Pattern.loc matchPattern) matchGuard) []
+
+    finalK :: loc -> Maybe (Term' vt v loc) -> [v] -> m (GrdTree (PmGrd vt v loc) loc)
+    finalK loc mterm vs = case mterm of
+      Nothing -> pure (Leaf loc)
+      Just grdExpr -> do
+        let ann = ABT.annotation grdExpr
+            expr = foldr (\a b -> app ann (var ann a) b) grdExpr vs
+            typ = Type.boolean ann
+        v <- fresh
+        pure (Grd (PmLet v expr typ) (Grd (PmLit v (PmLit.Boolean True)) (Leaf loc)))
+
+desugarPattern ::
+  forall v vt loc m.
+  (Pmc vt v loc m) =>
+  Type vt loc ->
+  v ->
+  Pattern loc ->
+  ([v] -> m (GrdTree (PmGrd vt v loc) loc)) ->
+  [v] ->
+  m (GrdTree (PmGrd vt v loc) loc)
+desugarPattern typ v0 pat k vs = case pat of
+  Unbound _ -> k vs
+  Var _ -> k (v0 : vs)
+  Boolean _ x -> Grd (PmLit v0 $ PmLit.Boolean x) <$> k vs
+  Int _ x -> Grd (PmLit v0 $ PmLit.Int x) <$> k vs
+  Nat _ x -> Grd (PmLit v0 $ PmLit.Nat x) <$> k vs
+  Float _ x -> Grd (PmLit v0 $ PmLit.Float x) <$> k vs
+  Text _ x -> Grd (PmLit v0 $ PmLit.Text x) <$> k vs
+  Char _ x -> Grd (PmLit v0 $ PmLit.Char x) <$> k vs
+  Constructor _loc consRef pats -> do
+    contyps <- getConstructorVarTypes typ consRef
+    patvars <- assignFreshPatternVars pats
+    let c = PmCon v0 consRef convars
+        convars :: [(v, Type vt loc)]
+        convars = map (\(v, _, t) -> (v, t)) tpatvars
+        tpatvars = zipWith (\(v, p) t -> (v, p, t)) patvars contyps
+    rest <- foldr (\(v, pat, t) b -> desugarPattern t v pat b) k tpatvars vs
+    pure (Grd c rest)
+  As _ rest -> desugarPattern typ v0 rest k (v0 : vs)
+  EffectPure {} -> k vs
+  EffectBind {} -> k vs
+  SequenceLiteral {} -> handleSequence typ v0 pat k vs
+  SequenceOp {} -> handleSequence typ v0 pat k vs
+
+handleSequence ::
+  forall v vt loc m.
+  (Pmc vt v loc m) =>
+  Type vt loc ->
+  v ->
+  Pattern loc ->
+  ([v] -> m (GrdTree (PmGrd vt v loc) loc)) ->
+  [v] ->
+  m (GrdTree (PmGrd vt v loc) loc)
+handleSequence typ v pat k vs = do
+  let listArg = case typ of
+        Type.App' _list arg -> arg
+        _ -> error "list type is not an application?"
+  listToGrdTree typ listArg v (normalizeList pat) k vs
+
+listToGrdTree ::
+  forall v vt loc m.
+  (Pmc vt v loc m) =>
+  Type vt loc ->
+  Type vt loc ->
+  v ->
+  NormalizedList loc ->
+  ([v] -> m (GrdTree (PmGrd vt v loc) loc)) ->
+  [v] ->
+  m (GrdTree (PmGrd vt v loc) loc)
+listToGrdTree _listTyp elemTyp listVar nl0 k0 vs0 =
+  let (minLen, maxLen) = countMinListLen nl0
+   in Grd (PmListInterval listVar minLen maxLen) <$> go 0 0 nl0 k0 vs0
+  where
+    go consCount snocCount (Fix pat) k vs = case pat of
+      N'ConsF x xs -> do
+        element <- fresh
+        let grd = PmListHead listVar consCount element elemTyp
+        let !consCount' = consCount + 1
+        Grd grd <$> desugarPattern elemTyp element x (go consCount' snocCount xs k) vs
+      N'SnocF xs x -> do
+        element <- fresh
+        let grd = PmListTail listVar snocCount element elemTyp
+        let !snocCount' = snocCount + 1
+        Grd grd <$> go consCount snocCount' xs (desugarPattern elemTyp element x k) vs
+      N'NilF -> k vs
+      N'VarF _ -> k (listVar : vs)
+      N'UnboundF _ -> k vs
+
+    countMinListLen :: NormalizedList loc -> (Int, Int)
+    countMinListLen =
+      ($ 0) . cata \case
+        N'ConsF _ b -> \acc -> b $! acc + 1
+        N'SnocF b _ -> \acc -> b $! acc + 1
+        N'NilF -> \ !n -> (n, n)
+        N'VarF _ -> \ !n -> (n, maxBound)
+        N'UnboundF _ -> \ !n -> (n, maxBound)
+
+data NormalizedListF loc a
+  = N'ConsF (Pattern loc) a
+  | N'SnocF a (Pattern loc)
+  | N'NilF
+  | N'VarF loc
+  | N'UnboundF loc
+  deriving stock (Functor)
+
+type NormalizedList loc = Fix (NormalizedListF loc)
+
+pattern N'Cons :: Pattern loc -> Fix (NormalizedListF loc) -> Fix (NormalizedListF loc)
+pattern N'Cons x xs = Fix (N'ConsF x xs)
+
+pattern N'Snoc :: Fix (NormalizedListF loc) -> Pattern loc -> Fix (NormalizedListF loc)
+pattern N'Snoc xs x = Fix (N'SnocF xs x)
+
+pattern N'Nil :: Fix (NormalizedListF loc)
+pattern N'Nil = Fix N'NilF
+
+pattern N'Var :: loc -> Fix (NormalizedListF loc)
+pattern N'Var x = Fix (N'VarF x)
+
+pattern N'Unbound :: loc -> Fix (NormalizedListF loc)
+pattern N'Unbound x = Fix (N'UnboundF x)
+
+-- | strip out sequence literals and concats
+normalizeList :: Pattern loc -> NormalizedList loc
+normalizeList pat0 = case goCons pat0 of
+  Left f -> f N'Nil
+  Right x -> x
+  where
+    goCons :: Pattern loc -> Either (NormalizedList loc -> NormalizedList loc) (NormalizedList loc)
+    goCons = \case
+      SequenceLiteral _loc xs ->
+        Left \nil -> foldr N'Cons nil xs
+      SequenceOp _loc lhs op rhs -> case op of
+        Cons ->
+          case goCons rhs of
+            Left f -> Left (N'Cons lhs . f)
+            Right x -> Right (N'Cons lhs x)
+        Snoc ->
+          case goCons lhs of
+            Left f -> Left (f . N'Cons rhs)
+            Right x -> Right (N'Snoc x rhs)
+        Concat ->
+          case goCons lhs of
+            Left f -> case goCons rhs of
+              Left g -> Left (f . g)
+              Right x -> Right (f x)
+            Right x -> Right (goSnoc rhs x)
+      Var loc -> Right (N'Var loc)
+      Unbound loc -> Right (N'Unbound loc)
+      -- as-patterns are not handled properly here, which is fine while we
+      -- only have boolean guards, but this needs to be fixed if we
+      -- introduce pattern guards
+      As _loc pat -> goCons pat
+      _ -> error "goCons: unexpected pattern"
+
+    goSnoc :: Pattern loc -> NormalizedList loc -> NormalizedList loc
+    goSnoc pat nlp = case pat of
+      SequenceLiteral _loc xs ->
+        foldl N'Snoc nlp xs
+      SequenceOp _loc lhs op rhs -> case op of
+        Cons ->
+          goSnoc rhs (N'Snoc nlp lhs)
+        Snoc ->
+          N'Snoc (goSnoc rhs nlp) lhs
+        Concat ->
+          goSnoc rhs (goSnoc lhs nlp)
+      As _loc pat -> goSnoc pat nlp
+      _ -> error "goSnoc: unexpected pattern"
+
+assignFreshPatternVars :: (Pmc vt v loc m) => [Pattern loc] -> m [(v, Pattern loc)]
+assignFreshPatternVars pats = traverse (\p -> (,p) <$> fresh) pats

parser-typechecker/src/Unison/PatternMatchCoverage/Fix.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Unison.PatternMatchCoverage.Fix where
+
+newtype Fix f = Fix {unFix :: f (Fix f)}
+
+deriving instance (forall a. (Show a) => Show (f a)) => Show (Fix f)
+
+deriving instance (forall a. (Eq a) => Eq (f a)) => Eq (Fix f)
+
+deriving instance (Eq (Fix f), forall a. (Ord a) => Ord (f a)) => Ord (Fix f)
+
+cata :: (Functor f) => (f a -> a) -> Fix f -> a
+cata alg = let c = alg . fmap c . unFix in c
+
+para :: (Functor f) => (f (Fix f, a) -> a) -> Fix f -> a
+para alg = let c = alg . fmap (\x -> (x, c x)) . unFix in c

parser-typechecker/src/Unison/PatternMatchCoverage/GrdTree.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Unison.PatternMatchCoverage.GrdTree
+  ( GrdTree,
+    GrdTreeF (..),
+    pattern Leaf,
+    pattern Grd,
+    pattern Fork,
+    prettyGrdTree,
+  )
+where
+
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as NEL
+import Data.ListLike (ListLike)
+import Unison.PatternMatchCoverage.Fix
+import Unison.Prelude
+import Unison.Util.Pretty
+
+-- | A @GrdTree@ is the simple language to desugar matches into. All
+-- pattern matching constructs (/e.g./ structural pattern matching,
+-- boolean guards, pattern guards, view patterns, etc) are desugared
+-- into this simpler structure.
+--
+-- It is parameterized by the values at guard nodes, @n@, and the
+-- values at the leaves, @l@. When desugaring, @n@ is
+-- 'Unison.PatternMatchCoverage.PmGrd.PmGrd' and @l@ is the source
+-- location. After annotating the @GrdTree@, @n@ is a refinement type
+-- representing matching values and the @l@ is pairs of the
+-- aforementioned refinement type and source location.
+--
+-- For example:
+--
+-- @
+-- example : Optional Nat -> Nat
+-- example = cases
+--   None -> 0
+--   Some x
+--     | isEven x -> 0
+--     | otherwise -> 1
+-- @
+--
+-- is desugared into
+--
+-- @
+--  ──┬─ None <- v0 ── srcloc
+--    ├─ Some ( v1 :: ##Nat ) <- v0 ── let v2 = isEven v1 ── True <- v2 ── srcloc
+--    └─ Some ( v3 :: ##Nat ) <- v0 ── srcloc
+-- @
+type GrdTree n l = Fix (GrdTreeF n l)
+
+data GrdTreeF n l a
+  = -- | A successful match
+    LeafF l
+  | -- | A constraint of some kind (structural pattern match, boolan guard, etc)
+    GrdF n a
+  | -- | A list of alternative matches, tried in order
+    ForkF (NonEmpty a)
+  deriving stock (Functor, Show)
+
+prettyGrdTree :: forall n l s. (ListLike s Char, IsString s) => (n -> Pretty s) -> (l -> Pretty s) -> GrdTree n l -> Pretty s
+prettyGrdTree prettyNode prettyLeaf = cata phi
+  where
+    phi = \case
+      LeafF l -> prettyLeaf l
+      GrdF n rest -> sep " " [prettyNode n, "──", rest]
+      ForkF xs -> "──" <> group (sep "\n" (makeTree $ NEL.toList xs))
+    makeTree :: [Pretty s] -> [Pretty s]
+    makeTree = \case
+      [] -> []
+      x : [] -> [sep " " ["──", x]]
+      x0 : x1 : xs ->
+        sep " " ["┬─", x0]
+          : let go y0 = \case
+                  [] -> [sep " " ["└─", y0]]
+                  y1 : ys -> "├─ " <> y0 : go y1 ys
+             in [indent "  " (sep "\n" (go x1 xs))]
+
+pattern Leaf :: l -> GrdTree n l
+pattern Leaf x = Fix (LeafF x)
+
+pattern Grd :: n -> GrdTree n l -> GrdTree n l
+pattern Grd x rest = Fix (GrdF x rest)
+
+pattern Fork :: NonEmpty (GrdTree n l) -> GrdTree n l
+pattern Fork alts = Fix (ForkF alts)
+
+{-# COMPLETE Leaf, Grd, Fork #-}

parser-typechecker/src/Unison/PatternMatchCoverage/IntervalSet.hs

@@ -0,0 +1,203 @@
+module Unison.PatternMatchCoverage.IntervalSet
+  ( IntervalSet,
+    empty,
+    singleton,
+    fromList,
+    insert,
+    delete,
+    difference,
+    intersection,
+    complement,
+    null,
+    member,
+    extractSingleton,
+    intersectIntervals,
+    map,
+    foldr,
+    lookupMin,
+    lookupMax,
+  )
+where
+
+import Data.Coerce (coerce)
+import Data.Function (on)
+import Data.IntMap (IntMap)
+import qualified Data.IntMap.Strict as IntMap
+import Data.List (sortOn)
+import Data.Maybe (catMaybes, fromMaybe, maybeToList)
+import Prelude hiding (foldr, map, null)
+import qualified Prelude
+
+newtype IntervalSet = IntervalSet {unIntervalSet :: IntMap Int}
+  deriving stock (Show, Eq, Ord)
+
+empty :: IntervalSet
+empty = IntervalSet IntMap.empty
+
+singleton :: (Int, Int) -> IntervalSet
+singleton x = insert x empty
+
+lookupMin :: IntervalSet -> Maybe Int
+lookupMin = fmap fst . IntMap.lookupMin . unIntervalSet
+
+lookupMax :: IntervalSet -> Maybe Int
+lookupMax = fmap snd . IntMap.lookupMax . unIntervalSet
+
+member :: Int -> IntervalSet -> Bool
+member i is =
+  case splitLookupLE i is of
+    (_, m, _) -> case m of
+      Nothing -> False
+      Just (_, ub) -> i <= ub
+
+foldr :: (Int -> Int -> b -> b) -> b -> IntervalSet -> b
+foldr f z = IntMap.foldrWithKey f z . unIntervalSet
+
+map :: ((Int, Int) -> (Int, Int)) -> IntervalSet -> IntervalSet
+map f = IntervalSet . foldr phi IntMap.empty
+  where
+    phi k v b = let (k', v') = f (k, v) in IntMap.insert k' v' b
+
+-- | insert inclusive bounds interval into set
+insert :: (Int, Int) -> IntervalSet -> IntervalSet
+insert i@(lb, ub) is
+  | nullInterval i = is
+  | otherwise =
+      case splitLookupLE lb is of
+        (smaller, m1, xs) ->
+          case splitLookupLE ub xs of
+            (_, m2, larger) ->
+              IntervalSet $
+                IntMap.unions
+                  [ unIntervalSet smaller,
+                    unIntervalSet $ fromList (maybeToList m1 ++ [i] ++ maybeToList m2),
+                    unIntervalSet larger
+                  ]
+
+delete :: (Int, Int) -> IntervalSet -> IntervalSet
+delete i@(lb, ub) is
+  | nullInterval i = is
+  | otherwise =
+      case splitLookupLE lb is of
+        (smaller, m1, xs) ->
+          case splitLookupLE ub xs of
+            (_, m2, larger) ->
+              IntervalSet $
+                IntMap.unions
+                  [ unIntervalSet smaller,
+                    case m1 of
+                      Nothing -> IntMap.empty
+                      Just j -> IntMap.fromList (catMaybes (Prelude.map (intersectIntervals j =<<) [upTo lb, downTo ub])),
+                    fromMaybe IntMap.empty do
+                      j <- m2
+                      aboveDelete <- downTo ub
+                      uncurry IntMap.singleton <$> intersectIntervals aboveDelete j,
+                    unIntervalSet larger
+                  ]
+
+complement :: IntervalSet -> IntervalSet
+complement (IntervalSet m) = fromAscList . (\xs -> Prelude.foldr phi z xs Nothing) . IntMap.toAscList $ m
+  where
+    phi (lb, ub) b mprevUb =
+      case mprevUb of
+        Nothing -> case upTo lb of
+          Nothing -> b (Just ub)
+          Just x -> x : b (Just ub)
+        Just lastUb ->
+          let !lbPred = safeAdd lb (-1)
+              !lastUbSucc = safeAdd lastUb 1
+              proposedInterval = (lastUbSucc, lbPred)
+           in case nullInterval proposedInterval of
+                True -> b (Just ub)
+                False -> proposedInterval : b (Just ub)
+    z = \case
+      Nothing -> [(0, maxBound)]
+      Just prev -> case downTo prev of
+        Nothing -> []
+        Just x -> [x]
+
+intersection :: IntervalSet -> IntervalSet -> IntervalSet
+intersection a b = difference a (complement b)
+
+null :: IntervalSet -> Bool
+null = IntMap.null . unIntervalSet
+
+extractSingleton :: IntervalSet -> Maybe Int
+extractSingleton (IntervalSet m) = case IntMap.toList m of
+  [(lb, ub)]
+    | lb == ub -> Just lb
+  _ -> Nothing
+
+-- | add two integers, sticking to a bound if it would overflow
+safeAdd :: Int -> Int -> Int
+safeAdd a b =
+  let c = a + b
+   in case a > 0 && b > 0 of
+        True -> case c < 0 of
+          True -> maxBound
+          False -> c
+        False -> case a < 0 && b < 0 of
+          True -> case c >= 0 of
+            True -> minBound
+            False -> c
+          False -> c
+
+difference :: IntervalSet -> IntervalSet -> IntervalSet
+difference x (IntervalSet y) = IntMap.foldlWithKey' (\b k v -> delete (k, v) b) x y
+
+-- | the interval [0, lb)
+upTo :: Int -> Maybe (Int, Int)
+upTo lb = case lb <= 0 of
+  True -> Nothing
+  False -> Just (0, safeAdd lb (-1))
+
+-- | the interval (ub, maxBound]
+downTo :: Int -> Maybe (Int, Int)
+downTo ub = case ub == maxBound of
+  True -> Nothing
+  False -> Just (safeAdd ub 1, maxBound)
+
+nullInterval :: (Int, Int) -> Bool
+nullInterval (lb, ub) = ub < lb
+
+-- | merge a list sorted on the lower bound ascending
+fromAscList :: [(Int, Int)] -> IntervalSet
+fromAscList = IntervalSet . IntMap.fromAscList . mergeOverlappingAscList
+
+fromList :: [(Int, Int)] -> IntervalSet
+fromList = fromAscList . sortOn fst . filter (not . nullInterval)
+
+intersectIntervals :: (Int, Int) -> (Int, Int) -> Maybe (Int, Int)
+intersectIntervals a b
+  | doOverlap a b =
+      let !lb = on max fst a b
+          !ub = on min snd a b
+       in Just (lb, ub)
+  | otherwise = Nothing
+
+mergeOverlappingAscList :: [(Int, Int)] -> [(Int, Int)]
+mergeOverlappingAscList = \case
+  x0 : x1 : xs -> case doOverlap x0 x1 of
+    True -> spanIntervals x0 x1 : mergeOverlappingAscList xs
+    False -> x0 : x1 : mergeOverlappingAscList xs
+  [x] -> [x]
+  [] -> []
+
+doOverlap :: (Int, Int) -> (Int, Int) -> Bool
+doOverlap (lb0, ub0) (lb1, ub1)
+  | ub0 >= lb1 && lb0 <= ub1 = True
+  | otherwise = False
+
+spanIntervals :: (Int, Int) -> (Int, Int) -> (Int, Int)
+spanIntervals (lb0, ub0) (lb1, ub1) =
+  let !lb = min lb0 lb1
+      !ub = max ub0 ub1
+   in (lb, ub)
+
+splitLookupLE :: Int -> IntervalSet -> (IntervalSet, Maybe (Int, Int), IntervalSet)
+splitLookupLE k (IntervalSet m) =
+  coerce case IntMap.splitLookup k m of
+    (smaller, Just v, larger) -> (smaller, Just (k, v), larger)
+    (smaller, Nothing, larger) -> case IntMap.maxViewWithKey smaller of
+      Just ((k, v), smaller) -> (smaller, Just (k, v), larger)
+      Nothing -> (smaller, Nothing, larger)

parser-typechecker/src/Unison/PatternMatchCoverage/ListPat.hs

@@ -0,0 +1,15 @@
+module Unison.PatternMatchCoverage.ListPat where
+
+import Unison.Util.Pretty
+
+data ListPat
+  = Cons
+  | Snoc
+  | Nil
+  deriving stock (Show, Eq, Ord)
+
+prettyListPat :: ListPat -> Pretty ColorText
+prettyListPat = \case
+  Cons -> "Cons"
+  Snoc -> "Snoc"
+  Nil -> "Nil"

parser-typechecker/src/Unison/PatternMatchCoverage/Literal.hs

@@ -0,0 +1,81 @@
+module Unison.PatternMatchCoverage.Literal
+  ( Literal (..),
+    prettyLiteral,
+  )
+where
+
+import Unison.ConstructorReference (ConstructorReference)
+import Unison.PatternMatchCoverage.IntervalSet (IntervalSet)
+import Unison.PatternMatchCoverage.PmLit (PmLit, prettyPmLit)
+import qualified Unison.PrettyPrintEnv as PPE
+import qualified Unison.Syntax.TermPrinter as TermPrinter
+import qualified Unison.Syntax.TypePrinter as TypePrinter
+import Unison.Term (Term')
+import Unison.Type (Type)
+import Unison.Typechecker.TypeVar (TypeVar, lowerTerm)
+import Unison.Util.Pretty
+import Unison.Var (Var)
+
+-- | Refinement type literals (fig 3)
+data Literal vt v loc
+  = -- | True
+    T
+  | -- | False
+    F
+  | -- | Positive constraint regarding data type. States that the
+    -- given variable must be the given constructor, and it also binds
+    -- variables corresponding to constructor arguments.
+    PosCon v ConstructorReference [(v, Type vt loc)]
+  | -- | Negative constraint concerning data type. States that the
+    -- given variable must not be the given constructor.
+    NegCon v ConstructorReference
+  | -- | Positive constraint regarding literal
+    PosLit v PmLit
+  | -- | Negative constraint regarding literal
+    NegLit v PmLit
+  | -- | Positive constraint on list element with position relative to head of list
+    PosListHead
+      v
+      -- ^ list root
+      Int
+      -- ^ cons position (0 is head)
+      v
+      -- ^ element variable
+      (Type vt loc)
+  | -- | Positive constraint on list element with position relative to end of list
+    PosListTail
+      v
+      -- ^ list root
+      Int
+      -- ^ snoc position (0 is last)
+      v
+      -- ^ element variable
+      (Type vt loc)
+  | -- | Negative constraint on length of the list (/i.e./ the list
+    -- may not be an element of the interval set)
+    NegListInterval v IntervalSet
+  | -- | An effect is performed
+    Effectful v
+  | -- | Introduce a binding for a term
+    Let v (Term' vt v loc) (Type vt loc)
+  deriving stock (Show)
+
+prettyLiteral :: (Var v) => Literal (TypeVar b v) v loc -> Pretty ColorText
+prettyLiteral = \case
+  T -> "✓"
+  F -> "⨉"
+  PosCon var con convars ->
+    let xs = pc con : fmap (\(trm, typ) -> sep " " [pv trm, ":", TypePrinter.pretty PPE.empty typ]) convars ++ ["<-", pv var]
+     in sep " " xs
+  NegCon var con -> sep " " [pv var, "≠", pc con]
+  PosLit var lit -> sep " " [prettyPmLit lit, "<-", pv var]
+  NegLit var lit -> sep " " [pv var, "≠", prettyPmLit lit]
+  PosListHead root n el _ -> sep " " [pv el, "<-", "head", pc n, pv root]
+  PosListTail root n el _ -> sep " " [pv el, "<-", "tail", pc n, pv root]
+  NegListInterval var x -> sep " " [pv var, "≠", string (show x)]
+  Effectful var -> "!" <> pv var
+  Let var expr typ -> sep " " ["let", pv var, "=", TermPrinter.pretty PPE.empty (lowerTerm expr), ":", TypePrinter.pretty PPE.empty typ]
+  where
+    pv = string . show
+    pc :: forall a. (Show a) => a -> Pretty ColorText
+    pc = string . show

parser-typechecker/src/Unison/PatternMatchCoverage/NormalizedConstraints.hs

@@ -0,0 +1,278 @@
+module Unison.PatternMatchCoverage.NormalizedConstraints
+  ( NormalizedConstraints (..),
+    VarInfo (..),
+    VarConstraints (..),
+    EffectInfo (..),
+    markDirty,
+    emptyNormalizedConstraints,
+    updateF,
+    ConstraintUpdate (..),
+    expectCanon,
+    declVar,
+    prettyNormalizedConstraints,
+    prettyDnf,
+  )
+where
+
+import Data.Functor.Compose
+import Data.List (intersperse)
+import Data.Sequence (pattern Empty)
+import qualified Data.Set as Set
+import Unison.ConstructorReference (ConstructorReference)
+import Unison.PatternMatchCoverage.Constraint
+import Unison.PatternMatchCoverage.IntervalSet (IntervalSet)
+import qualified Unison.PatternMatchCoverage.IntervalSet as IntervalSet
+import qualified Unison.PatternMatchCoverage.PmLit as PmLit
+import Unison.PatternMatchCoverage.UFMap (UFMap)
+import qualified Unison.PatternMatchCoverage.UFMap as UFMap
+import Unison.Prelude
+import qualified Unison.PrettyPrintEnv as PPE
+import qualified Unison.Syntax.TypePrinter as TypePrinter
+import Unison.Type (Type, booleanRef, charRef, floatRef, intRef, listRef, natRef, textRef, pattern App', pattern Ref')
+import Unison.Util.Pretty
+import Unison.Var (Var)
+
+-- | Normalized refinement types (fig 6)
+--
+-- Each variable may be associated with a number of constraints
+-- represented by 'VarInfo'. A 'NormalizedConstraints' is conceptually
+-- the conjunction of all constraints in the map. Disjunction is
+-- represented by passing a Set of NormalizedConstraints. So, the
+-- constraints are normalized into disjunctive normal form and each
+-- @NormalizedConstraints@ is a DNF term.
+--
+-- Additionally, the following invariants are enforced (Section 3.4)
+--
+-- * Mutual compatibility: No two constraints should conflict with
+-- each other.
+--
+-- * Inhabitation: There must be at least one value that inhabits each
+-- refinement type. (N.B. We don't truly know if a type is inhabited,
+-- see 'inhabited' in "Unison.PatternMatchCoverage.Solve" for
+-- details. However, the refinement type is inhabited as far as our
+-- inhabitation checker is concerned.)
+--
+-- These invariants ensure that each term in our DNF has at least one
+-- solution, and it is easy to expand and print these solutions.
+data NormalizedConstraints vt v loc = NormalizedConstraints
+  { -- | Constraints keyed by the variable they constrain. Equality
+    -- constraints are handled by 'UFMap'.
+    constraintMap :: UFMap v (VarInfo vt v loc),
+    -- | dirty variables are ones that must be checked for inhabitance
+    dirtySet :: Set v
+  }
+  deriving stock (Eq, Ord, Show)
+
+-- | Mark a variable as requiring a new test for inhabitation.
+markDirty ::
+  (Ord v) =>
+  v ->
+  NormalizedConstraints vt v loc ->
+  NormalizedConstraints vt v loc
+markDirty k nc@NormalizedConstraints {dirtySet} =
+  nc {dirtySet = Set.insert k dirtySet}
+
+emptyNormalizedConstraints :: (Ord v) => NormalizedConstraints vt v loc
+emptyNormalizedConstraints =
+  NormalizedConstraints
+    { constraintMap = UFMap.empty,
+      dirtySet = mempty
+    }
+
+-- | Lookup the canonical value of @v@ from the constraint map. Throws
+-- an error if the variable is not in the map.
+expectCanon ::
+  forall vt v loc.
+  (Var v) =>
+  v ->
+  NormalizedConstraints vt v loc ->
+  (v, VarInfo vt v loc, NormalizedConstraints vt v loc)
+expectCanon k nc =
+  let ((v, vi), nc') = updateF k (\v vi -> ((v, vi), Ignore)) nc
+   in (v, vi, nc')
+
+-- | Alter a constraint, marks var as dirty if updated
+alterF ::
+  forall vt v loc f.
+  (Var v, Functor f) =>
+  v ->
+  f (ConstraintUpdate (VarInfo vt v loc)) ->
+  (v -> VarInfo vt v loc -> f (ConstraintUpdate (VarInfo vt v loc))) ->
+  NormalizedConstraints vt v loc ->
+  f (NormalizedConstraints vt v loc)
+alterF v nothing just nc =
+  (\(f, x) -> f nc {constraintMap = x})
+    <$> getCompose
+      ( UFMap.alterF
+          v
+          nothing'
+          just'
+          (constraintMap nc)
+      )
+  where
+    just' canonK eqClassSize vi =
+      fmap (UFMap.Canonical eqClassSize) $
+        Compose $
+          just canonK vi <&> \case
+            Ignore -> (id, vi)
+            Update vi -> (markDirty canonK, vi)
+    nothing' =
+      Compose $
+        nothing <&> \case
+          Ignore -> (id, Nothing)
+          Update x -> (markDirty v, Just x)
+{-# INLINE alterF #-}
+
+-- | Generic function to lookup or alter constraints in the constraint
+-- map. Throws an error if the variable is not in the map.
+updateF ::
+  forall vt v loc f.
+  (Var v, Functor f) =>
+  -- | variable to lookup
+  v ->
+  -- | update function
+  (v -> VarInfo vt v loc -> f (ConstraintUpdate (VarInfo vt v loc))) ->
+  -- | constraint map
+  NormalizedConstraints vt v loc ->
+  f (NormalizedConstraints vt v loc)
+updateF v just nc =
+  alterF v nothing just nc
+  where
+    nothing = error ("expected " <> show v <> " to be in UFMap")
+
+data ConstraintUpdate a
+  = Update a
+  | Ignore
+  deriving stock (Functor)
+
+-- | Install a new variable into the constraint map. Throws an error
+-- if the variable already exists in the map.
+declVar ::
+  forall vt v loc.
+  (Var v) =>
+  -- | new variable to install
+  v ->
+  -- | type of variable
+  Type vt loc ->
+  -- | modifier for the default var info of the given type
+  (VarInfo vt v loc -> VarInfo vt v loc) ->
+  -- | Normalized constraints to install the variable into
+  NormalizedConstraints vt v loc ->
+  NormalizedConstraints vt v loc
+declVar v t f nc@NormalizedConstraints {constraintMap} =
+  nc {constraintMap = UFMap.alter v nothing just constraintMap}
+  where
+    nothing =
+      let !vi = f (mkVarInfo v t)
+       in Just vi
+    just _ _ _ = error ("attempted to declare: " <> show v <> " but it already exists")
+
+mkVarInfo :: forall vt v loc. v -> Type vt loc -> VarInfo vt v loc
+mkVarInfo v t =
+  VarInfo
+    { vi_id = v,
+      vi_typ = t,
+      vi_con = case t of
+        App' (Ref' r) t
+          | r == listRef -> Vc'ListRoot t Empty Empty (IntervalSet.singleton (0, maxBound))
+        Ref' r
+          | r == booleanRef -> Vc'Boolean Nothing mempty
+          | r == intRef -> Vc'Int Nothing mempty
+          | r == natRef -> Vc'Nat Nothing mempty
+          | r == floatRef -> Vc'Float Nothing mempty
+          | r == textRef -> Vc'Text Nothing mempty
+          | r == charRef -> Vc'Char Nothing mempty
+        -- this may not be a constructor, but we won't be producing
+        -- any constraints for it in that case anyway
+        _ -> Vc'Constructor Nothing mempty,
+      vi_eff = IsNotEffectful
+    }
+
+-- | Normalized constraints on a specific variable
+data VarInfo vt v loc = VarInfo
+  { vi_id :: v,
+    vi_typ :: Type vt loc,
+    vi_con :: VarConstraints vt v loc,
+    vi_eff :: EffectInfo
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+
+-- | The constraints are different for different types, although most
+-- of them take the form of an optional positive constraint and a set
+-- of negative constraints.
+data VarConstraints vt v loc
+  = Vc'Constructor
+      (Maybe (ConstructorReference, [(v, Type vt loc)]))
+      (Set ConstructorReference)
+  | Vc'Boolean (Maybe Bool) (Set Bool)
+  | Vc'Int (Maybe Int64) (Set Int64)
+  | Vc'Nat (Maybe Word64) (Set Word64)
+  | Vc'Float (Maybe Double) (Set Double)
+  | Vc'Text (Maybe Text) (Set Text)
+  | Vc'Char (Maybe Char) (Set Char)
+  | Vc'ListRoot
+      (Type vt loc)
+      -- ^ type of list elems
+      (Seq v)
+      -- ^ Positive constraint on cons elements
+      (Seq v)
+      -- ^ Positive constraint on snoc elements
+      IntervalSet
+      -- ^ positive constraint on input list size
+  deriving stock (Show, Eq, Ord, Generic)
+
+data EffectInfo
+  = IsEffectful
+  | IsNotEffectful
+  deriving stock (Show, Eq, Ord)
+
+prettyNormalizedConstraints :: forall vt v loc. (Var v, Var vt) => NormalizedConstraints vt v loc -> Pretty ColorText
+prettyNormalizedConstraints (NormalizedConstraints {constraintMap}) = sep " " ["⟨", pconstraints, "⟩"]
+  where
+    cls = UFMap.toClasses constraintMap
+
+    pconstraints = sep " " (intersperse "," $ prettyCon <$> cls)
+    prettyCon (kcanon, ks, vi) =
+      let posCon = fromMaybe [] $ case vi_con vi of
+            Vc'Constructor pos _neg ->
+              (\(datacon, convars) -> [PosCon kcanon datacon convars]) <$> pos
+            Vc'Boolean pos _neg ->
+              (\x -> [PosLit kcanon (PmLit.Boolean x)]) <$> pos
+            Vc'Int pos _neg ->
+              (\x -> [PosLit kcanon (PmLit.Int x)]) <$> pos
+            Vc'Nat pos _neg ->
+              (\x -> [PosLit kcanon (PmLit.Nat x)]) <$> pos
+            Vc'Float pos _neg ->
+              (\x -> [PosLit kcanon (PmLit.Float x)]) <$> pos
+            Vc'Text pos _neg ->
+              (\x -> [PosLit kcanon (PmLit.Text x)]) <$> pos
+            Vc'Char pos _neg ->
+              (\x -> [PosLit kcanon (PmLit.Char x)]) <$> pos
+            Vc'ListRoot _typ posCons posSnoc _iset ->
+              let consConstraints = fmap (\(i, x) -> PosListHead kcanon i x) (zip [0 ..] (toList posCons))
+                  snocConstraints = fmap (\(i, x) -> PosListTail kcanon i x) (zip [0 ..] (toList posSnoc))
+               in Just (consConstraints ++ snocConstraints)
+          negConK :: forall x. Set x -> (v -> x -> Constraint vt v loc) -> [Constraint vt v loc]
+          negConK s f = foldr (\a b -> f kcanon a : b) [] s
+          negCon = case vi_con vi of
+            Vc'Constructor _pos neg -> negConK neg NegCon
+            Vc'Boolean _pos neg -> negConK neg (\v a -> NegLit v (PmLit.Boolean a))
+            Vc'Int _pos neg -> negConK neg (\v a -> NegLit v (PmLit.Int a))
+            Vc'Nat _pos neg -> negConK neg (\v a -> NegLit v (PmLit.Nat a))
+            Vc'Float _pos neg -> negConK neg (\v a -> NegLit v (PmLit.Float a))
+            Vc'Text _pos neg -> negConK neg (\v a -> NegLit v (PmLit.Text a))
+            Vc'Char _pos neg -> negConK neg (\v a -> NegLit v (PmLit.Char a))
+            Vc'ListRoot _typ _posCons _posSnoc iset -> [NegListInterval kcanon (IntervalSet.complement iset)]
+          botCon = case vi_eff vi of
+            IsNotEffectful -> []
+            IsEffectful -> [Effectful kcanon]
+       in sep " " $
+            pv kcanon
+              : fmap pv (Set.toList $ Set.delete kcanon ks)
+              ++ [":", TypePrinter.pretty PPE.empty (vi_typ vi)]
+              ++ ["|"]
+              ++ [sep ", " $ fmap prettyConstraint (posCon ++ negCon ++ botCon)]
+    pv = string . show
+
+prettyDnf :: (Var v, Var vt) => Set (NormalizedConstraints vt v loc) -> Pretty ColorText
+prettyDnf xs = sep " " ("{" : intersperse "," (prettyNormalizedConstraints <$> Set.toList xs) ++ ["}"])

parser-typechecker/src/Unison/PatternMatchCoverage/PmGrd.hs

@@ -0,0 +1,64 @@
+module Unison.PatternMatchCoverage.PmGrd where
+
+import Unison.ConstructorReference (ConstructorReference)
+import Unison.PatternMatchCoverage.PmLit (PmLit, prettyPmLit)
+import qualified Unison.PrettyPrintEnv as PPE
+import qualified Unison.Syntax.TypePrinter as TypePrinter
+import Unison.Term (Term')
+import Unison.Type (Type)
+import Unison.Util.Pretty
+import Unison.Var (Var)
+
+data
+  PmGrd
+    vt -- Type variable
+    v -- Term variable
+    loc -- annotation
+  = -- | @PmCon x Con xs ys@ corresponds to the constraint @Con ys <- x@
+    PmCon
+      v
+      -- ^ Variable
+      ConstructorReference
+      -- ^ Constructor
+      [(v, Type vt loc)]
+      -- ^ Constructor argument values and types
+  | PmLit v PmLit
+  | PmListHead
+      v
+      -- ^ list root
+      Int
+      -- ^ cons position (0 is head)
+      v
+      -- ^ element variable
+      (Type vt loc)
+      -- ^ element type
+  | PmListTail
+      v
+      -- ^ list root
+      Int
+      -- ^ snoc position (0 is last)
+      v
+      -- ^ element variable
+      (Type vt loc)
+      -- ^ element type
+  | -- | The size of the list must fall within this inclusive range
+    PmListInterval v Int Int
+  | -- | If a guard performs an effect
+    PmBang v
+  | -- | @PmLet x expr@ corresponds to a @let x = expr@ guard. This actually
+    -- /binds/ @x@.
+    PmLet v (Term' vt v loc) (Type vt loc)
+  deriving stock (Show)
+
+prettyPmGrd :: (Var vt, Var v) => PmGrd vt v loc -> Pretty ColorText
+prettyPmGrd = \case
+  PmCon var con convars ->
+    let xs = string (show con) : (formatConVar <$> convars) ++ ["<-", string (show var)]
+        formatConVar (v, t) = sep " " ["(", string (show v), ":", TypePrinter.pretty PPE.empty t, ")"]
+     in sep " " xs
+  PmListHead var n el _ -> sep " " ["Cons", string (show n), string (show el), "<-", string (show var)]
+  PmListTail var n el _ -> sep " " ["Snoc", string (show n), string (show el), "<-", string (show var)]
+  PmListInterval var minLen maxLen -> sep " " ["Interval", string (show (minLen, maxLen)), "<-", string (show var)]
+  PmLit var lit -> sep " " [prettyPmLit lit, "<-", string (show var)]
+  PmBang v -> "!" <> string (show v)
+  PmLet v _expr _ -> sep " " ["let", string (show v), "=", "<expr>"]

parser-typechecker/src/Unison/PatternMatchCoverage/PmLit.hs

@@ -0,0 +1,23 @@
+module Unison.PatternMatchCoverage.PmLit where
+
+import Unison.Prelude
+import Unison.Util.Pretty (Pretty, string)
+
+data PmLit
+  = Int Int64
+  | Nat Word64
+  | Boolean Bool
+  | Float Double
+  | Text Text
+  | Char Char
+  deriving stock (Show, Eq, Ord)
+
+prettyPmLit :: (IsString s) => PmLit -> Pretty s
+prettyPmLit =
+  string . \case
+    Int x -> show x
+    Nat x -> show x
+    Boolean x -> show x
+    Float x -> show x
+    Text x -> show x
+    Char x -> show x

parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs

@@ -0,0 +1,883 @@
+{-# LANGUAGE DataKinds #-}
+
+module Unison.PatternMatchCoverage.Solve
+  ( uncoverAnnotate,
+    classify,
+    expandSolution,
+    generateInhabitants,
+  )
+where
+
+import Control.Monad.State
+import Control.Monad.Trans.Compose
+import Control.Monad.Trans.Maybe
+import Data.Foldable
+import Data.Function
+import Data.Functor
+import Data.Functor.Compose
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.Sequence as Seq
+import qualified Data.Set as Set
+import Unison.Builtin.Decls (unitRef)
+import Unison.ConstructorReference (ConstructorReference)
+import Unison.Debug (DebugFlag (PatternCoverageConstraintSolver), shouldDebug)
+import Unison.Pattern (Pattern)
+import qualified Unison.Pattern as Pattern
+import Unison.PatternMatchCoverage.Class
+import Unison.PatternMatchCoverage.Constraint (Constraint)
+import qualified Unison.PatternMatchCoverage.Constraint as C
+import Unison.PatternMatchCoverage.Fix
+import Unison.PatternMatchCoverage.GrdTree
+import Unison.PatternMatchCoverage.IntervalSet (IntervalSet)
+import qualified Unison.PatternMatchCoverage.IntervalSet as IntervalSet
+import Unison.PatternMatchCoverage.Literal
+import Unison.PatternMatchCoverage.NormalizedConstraints
+import Unison.PatternMatchCoverage.PmGrd
+import Unison.PatternMatchCoverage.PmLit (PmLit)
+import qualified Unison.PatternMatchCoverage.PmLit as PmLit
+import qualified Unison.PatternMatchCoverage.UFMap as UFMap
+import Unison.Prelude
+import Unison.Type (Type)
+import qualified Unison.Type as Type
+import qualified Unison.Util.Pretty as P
+import Unison.Var (Var)
+
+-- | top-down traversal of the 'GrdTree' that produces:
+--
+-- * a refinement type describing values that do not match the 'GrdTree'
+--   (the "uncovered" set)
+-- * a new 'GrdTree' annotated with refinement types at the nodes describing
+--   values that cause an effect to be performed and values that match
+--   the case at the leaves.
+--
+-- If the former is inhabited then its inhabitants are unmatched
+-- values. If the leaves of the latter are inhabited then the case is
+-- redundant.
+uncoverAnnotate ::
+  forall vt v loc m l.
+  (Pmc vt v loc m) =>
+  Set (NormalizedConstraints vt v loc) ->
+  GrdTree (PmGrd vt v loc) l ->
+  ( m
+      ( Set (NormalizedConstraints vt v loc),
+        GrdTree (Set (NormalizedConstraints vt v loc)) (Set (NormalizedConstraints vt v loc), l)
+      )
+  )
+uncoverAnnotate z grdtree0 = cata phi grdtree0 z
+  where
+    phi = \case
+      -- There is no way to fail matching a leaf, return the empty set
+      -- to represent false.
+      LeafF l -> \nc -> do
+        nc' <- ensureInhabited' nc
+        pure (Set.empty, Leaf (nc', l))
+      ForkF (kinit :| ks) -> \nc0 -> do
+        -- depth-first fold in match-case order to acculate the
+        -- constraints for a match failure at every case.
+        (nc1, t1) <- kinit nc0
+        (ncfinal, ts) <- foldlM (\(nc, ts) a -> a nc >>= \(nc', t) -> pure (nc', t : ts)) (nc1, []) ks
+        pure (ncfinal, Fork (t1 :| reverse ts))
+      GrdF grd k -> \nc0 -> case grd of
+        PmCon var con convars -> do
+          handleGrd (PosCon var con convars) (NegCon var con) k nc0
+        PmLit var lit -> do
+          handleGrd (PosLit var lit) (NegLit var lit) k nc0
+        PmListHead listVar n el elt -> do
+          nc <- addLiteral' nc0 (PosListHead listVar n el elt)
+          k nc
+        PmListTail listVar n el elt -> do
+          nc <- addLiteral' nc0 (PosListTail listVar n el elt)
+          k nc
+        PmListInterval listVar lb ub -> do
+          let iset = IntervalSet.singleton (lb, ub)
+          handleGrd (NegListInterval listVar (IntervalSet.complement iset)) (NegListInterval listVar iset) k nc0
+        PmBang var -> do
+          (ncCont, t) <- k nc0
+          ncEff <- addLiteral' nc0 (Effectful var)
+          let t' = Grd ncEff t
+          pure (ncCont, t')
+        PmLet var expr typ -> do
+          nc <- addLiteral' nc0 (Let var expr typ)
+          k nc
+
+    -- Constructors and literals are handled uniformly except that
+    -- they pass different positive and negative literals.
+    handleGrd pos neg k nc0 = do
+      ncNoMatch <- addLiteral' nc0 neg
+      ncMatch <- addLiteral' nc0 pos
+      (ncMatch, t) <- k ncMatch
+      -- A match can fail bacause it fails to match the immediate
+      -- pattern or it can match the immediate pattern but fail to
+      -- match some pattern or guard defined later in this same case.
+      --
+      -- This split can lead to an exponential number of terms, so we
+      -- limit this growth to a constant, conservatively
+      -- approximating. This is known as "throttling" in the paper and
+      -- described in section 5.2.
+      let ncFinalCandidate = Set.union ncMatch ncNoMatch
+          ncFinal = case Set.size ncFinalCandidate >= 30 of
+            True -> nc0
+            False -> ncFinalCandidate
+      pure (ncFinal, t)
+
+    ensureInhabited' ::
+      Set (NormalizedConstraints vt v loc) ->
+      m (Set (NormalizedConstraints vt v loc))
+    ensureInhabited' ncs0 = foldlM phi Set.empty ncs0
+      where
+        phi ncs nc =
+          ensureInhabited initFuel nc <&> \case
+            Nothing -> ncs
+            Just nc -> Set.insert nc ncs
+
+    -- Add a literal to each term in our DNF, dropping terms that
+    -- become contradictory
+    addLiteral' ::
+      Set (NormalizedConstraints vt v loc) ->
+      Literal vt v loc ->
+      m (Set (NormalizedConstraints vt v loc))
+    addLiteral' ncs0 lit = foldlM phi Set.empty ncs0
+      where
+        phi ncs nc =
+          addLiteral lit nc <&> \case
+            Nothing -> ncs
+            Just nc -> Set.insert nc ncs
+
+-- | Collect accessible, inaccessible, and redundant GRHSs
+classify ::
+  forall vt v loc l.
+  GrdTree (Set (NormalizedConstraints vt v loc)) (Set (NormalizedConstraints vt v loc), l) ->
+  ([l], [l], [l])
+classify = cata classifyAlg
+
+classifyAlg ::
+  forall vt v loc l.
+  GrdTreeF (Set (NormalizedConstraints vt v loc)) (Set (NormalizedConstraints vt v loc), l) ([l], [l], [l]) ->
+  ([l], [l], [l])
+classifyAlg = \case
+  LeafF (rt, l) ->
+    case inh rt of
+      True -> ([l], [], [])
+      False -> ([], [], [l])
+  GrdF rt rest ->
+    -- The presence of a 'GrdF' node indicates that an effect was
+    -- performed (see 'uncoverAnnotate').
+    case inh rt of
+      True ->
+        -- The rest of the subtree is redundant, but an effect is
+        -- performed. Classify this as "Inaccessible".
+        case rest of
+          ([], [], x : xs) -> ([], [x], xs)
+          _ -> rest
+      False -> rest
+  ForkF xs -> foldr (\(a, b, c) ~(acc, inacc, redun) -> (a ++ acc, b ++ inacc, c ++ redun)) ([], [], []) xs
+  where
+    -- inhabitation check
+    inh = not . Set.null
+
+-- | Expand a full DNF term (i.e. each term identifies exactly one
+-- solution) into an inhabiting pattern.
+generateInhabitants ::
+  forall vt v loc.
+  (Var v) =>
+  v ->
+  NormalizedConstraints vt v loc ->
+  Pattern ()
+generateInhabitants x nc =
+  let (_xcanon, xvi, nc') = expectCanon x nc
+   in case vi_con xvi of
+        Vc'Constructor pos _neg -> case pos of
+          Nothing -> Pattern.Unbound ()
+          Just (dc, convars) ->
+            Pattern.Constructor () dc (map (\(v, _) -> generateInhabitants v nc') convars)
+        Vc'Boolean pos _neg -> case pos of
+          Nothing -> Pattern.Unbound ()
+          Just b -> Pattern.Boolean () b
+        Vc'ListRoot _typ consPos snocPos intset ->
+          let matchedLength = on (+) length consPos snocPos
+              mmaxLength = IntervalSet.lookupMax intset
+              matchIsIncomplete = case mmaxLength of
+                Nothing -> True
+                Just maxLength -> matchedLength < maxLength
+              rootPat = case matchIsIncomplete of
+                True -> Pattern.Unbound ()
+                False -> Pattern.SequenceLiteral () []
+              snoced = foldr (\a b -> Pattern.SequenceOp () b Pattern.Snoc (generateInhabitants a nc')) rootPat snocPos
+              consed = foldr (\a b -> Pattern.SequenceOp () (generateInhabitants a nc') Pattern.Cons b) snoced consPos
+           in consed
+        _ -> Pattern.Unbound ()
+
+-- | Instantiate a variable to a given constructor.
+instantiate ::
+  forall vt v loc x m.
+  (Pmc vt v loc m) =>
+  Fuel ->
+  NormalizedConstraints vt v loc ->
+  v ->
+  -- | constructor
+  x ->
+  -- | type of datacon's args
+  [Type vt loc] ->
+  -- | produce positive constraint
+  (v -> x -> [(v, Type vt loc)] -> [Constraint vt v loc]) ->
+  m (Maybe (NormalizedConstraints vt v loc, [(v, Type vt loc)]))
+instantiate fuel nc x c argTyps posConstraint = do
+  -- todo: centralize this declVar logic. Currently in 'addLiteral' and here.
+  newVars :: [(var, typ)] <- traverse (\t -> (,t) <$> fresh) argTyps
+  let nc' = foldr (\(v, t) b -> declVar v t id b) nc newVars
+      cons = posConstraint x c newVars
+  mnc <- runMaybeT do
+    nc <- MaybeT (addConstraints cons nc')
+    -- mark all new fields as dirty as we need to ensure they are
+    -- inhabited
+    let nc' = foldr (\(v, _) b -> markDirty v b) nc newVars
+    -- branching factor
+    let newFuel = case length newVars > 1 of
+          True -> min fuel 3
+          False -> fuel
+    -- we must ensure that all strict fields are inhabited
+    MaybeT (ensureInhabited newFuel nc')
+  pure ((\x -> (x, newVars)) <$> mnc)
+
+-- | Given a variable and a term in DNF, expand it to an identical DNF
+-- expression with enough positive info to print pattern suggestions.
+expandSolution ::
+  forall vt v loc m.
+  (Pmc vt v loc m) =>
+  v ->
+  NormalizedConstraints vt v loc ->
+  m (Set (NormalizedConstraints vt v loc))
+expandSolution x nc =
+  let go fuel x nc
+        -- If we run out of fuel conservatively assume the term is
+        -- inhabited.
+        | fuel == 0 = pure (Set.singleton nc)
+        | otherwise =
+            let (_xcanon, xvi, nc') = expectCanon x nc
+             in withConstructors (pure (Set.singleton nc')) xvi \cs posConstraint _negConstraint ->
+                  -- We have some constructors to attempt
+                  -- instantiation with. Instantiate each one, if
+                  -- doesn't lead to a contradiction then add it to
+                  -- the set of valid solutions.
+                  let phi (cref, cvt) = do
+                        instantiate initFuel nc' x cref cvt posConstraint >>= \case
+                          Nothing -> pure Set.empty -- contradiction
+                          Just (nc'', newVars) -> case newVars of
+                            [] -> pure (Set.singleton nc'')
+                            _ ->
+                              -- If we have the match expression:
+                              -- @
+                              -- match blerg : Maybe (Maybe ()) with
+                              --   Nothing -> ()
+                              --   Just Nothing -> ()
+                              -- @
+                              --
+                              -- Then we would like to suggest @Just (Just _)@ rather than @Just _@.
+                              -- To accomplish this, we recurse and expand variables for which we have
+                              -- positive or negative information.
+
+                              -- branching factor
+                              let newFuel = case length newVars > 1 of
+                                    True -> min fuel 3
+                                    False -> fuel
+                               in Set.fromList
+                                    <$> foldlM
+                                      ( \b (v, _t) ->
+                                          Set.toList . Set.unions
+                                            <$> traverse
+                                              ( \nc ->
+                                                  case expectCanon v nc of
+                                                    (_vc, vi, nc') -> case vi_con vi of
+                                                      Vc'Constructor pos neg
+                                                        -- always instantiate unit, this ensures we print tuple patterns correctly
+                                                        | Type.Ref' x <- vi_typ vi, x == unitRef -> go newFuel v nc'
+                                                        | Just _ <- pos -> go newFuel v nc'
+                                                        | not (Set.null neg) -> go (newFuel - 1) v nc'
+                                                      Vc'Boolean _pos neg
+                                                        | not (Set.null neg) -> go (newFuel - 1) v nc'
+                                                      Vc'ListRoot _typ _posCons _posSnoc neg
+                                                        | not (IntervalSet.singleton (0, maxBound) == neg) -> go (newFuel - 1) v nc'
+                                                      _ -> pure (Set.singleton nc')
+                                              )
+                                              b
+                                      )
+                                      [nc'']
+                                      newVars
+                   in foldr (\a b s -> phi a >>= \a' -> b (Set.union a' s)) pure cs Set.empty
+   in go initFuel x nc
+
+withConstructors ::
+  forall vt v loc r m.
+  (Pmc vt v loc m) =>
+  m r ->
+  VarInfo vt v loc ->
+  ( forall x.
+    [(x, [Type vt loc])] ->
+    (v -> x -> [(v, Type vt loc)] -> [Constraint vt v loc]) ->
+    (v -> x -> Constraint vt v loc) ->
+    m r
+  ) ->
+  m r
+withConstructors nil vinfo k = do
+  getConstructors typ >>= \case
+    ConstructorType cs -> do
+      arg <- for cs \(v, cref, _) -> do
+        cvts <- getConstructorVarTypes typ cref
+        pure ((v, cref), cvts)
+      k arg (\v (_, cref) args -> [C.PosCon v cref args]) (\v (_, cref) -> C.NegCon v cref)
+    SequenceType _cs ->
+      let Vc'ListRoot elemType consPos snocPos iset = case vi_con vinfo of
+            Vc'ListRoot {} -> vi_con vinfo
+            _ -> error "impossible: constraint for sequence type not a list root"
+          varCount = length consPos + length snocPos
+          minLen = fromMaybe 0 $ IntervalSet.lookupMin iset
+
+          mkPosCons :: (Int -> [v] -> [Constraint vt v loc]) -> Int -> [v] -> [Constraint vt v loc]
+          mkPosCons z elvs0 = foldr (\_ b n (elv : elvs) -> C.PosListHead v n elv : b (n + 1) elvs) z consPos elvs0
+
+          mkPosSnoc :: (Int -> [v] -> [Constraint vt v loc]) -> Int -> [v] -> [Constraint vt v loc]
+          mkPosSnoc z elvs0 = foldr (\_ b n (elv : elvs) -> C.PosListTail v n elv : b (n + 1) elvs) z snocPos elvs0
+
+          constraints :: [(([(v, Type vt loc)] -> [Constraint vt v loc], Constraint vt v loc), [Type vt loc])]
+          constraints =
+            let mk f elvs = mkPosCons (\_ elvs -> mkPosSnoc (\_ elvs -> f elvs) 0 elvs) 0 (map fst elvs)
+             in [ ((mk \[] -> [], C.NegListInterval v (IntervalSet.singleton (minLen, maxBound))), replicate varCount elemType)
+                ]
+
+          mkPos _v (pos, _neg) args =
+            pos args
+          mkNeg _v (_pos, neg) =
+            neg
+       in k constraints mkPos mkNeg
+    BooleanType -> do
+      k [(True, []), (False, [])] (\v b _ -> [C.PosLit v (PmLit.Boolean b)]) (\v b -> C.NegLit v (PmLit.Boolean b))
+    OtherType -> nil
+  where
+    typ = vi_typ vinfo
+    v = vi_id vinfo
+
+-- | Test that the given variable is inhabited. This test is
+-- undecidable in general so we adopt a fuel based approach as
+-- described in section 3.7.
+inhabited ::
+  forall vt v loc m.
+  (Pmc vt v loc m) =>
+  Fuel ->
+  v ->
+  NormalizedConstraints vt v loc ->
+  m (Maybe (NormalizedConstraints vt v loc))
+inhabited fuel x nc0 =
+  let (_xcanon, xvi, nc') = expectCanon x nc0
+   in withConstructors (pure (Just nc')) xvi \cs posConstraint negConstraint ->
+        -- one of the constructors must be inhabited, Return the
+        -- first non-contradictory instantiation.
+        let phi (cref, cvt) b nc = do
+              instantiate fuel nc x cref cvt posConstraint >>= \case
+                Nothing -> do
+                  -- record failed instantiation attempt so we don't
+                  -- attempt to instantiate this constructor again
+                  addConstraint (negConstraint x cref) nc >>= \case
+                    Nothing -> b nc
+                    Just nc -> b nc
+                Just _ -> pure (Just nc)
+         in foldr phi (\_ -> pure Nothing) cs nc'
+
+newtype Fuel = Fuel Int
+  deriving newtype (Show, Eq, Ord, Enum, Bounded, Num)
+
+initFuel :: Fuel
+initFuel = 8
+
+-- | Check that all variables marked dirty are inhabited.
+ensureInhabited ::
+  forall vt v loc m.
+  (Pmc vt v loc m) =>
+  Fuel ->
+  NormalizedConstraints vt v loc ->
+  m (Maybe (NormalizedConstraints vt v loc))
+ensureInhabited fuel nc0@NormalizedConstraints {dirtySet}
+  | fuel == 0 = pure (Just clean) -- out of fuel, assume inhabited
+  | otherwise = do
+      -- all dirty vars must be inhabited or this NormalizedConstraints
+      -- is dropped
+      let phi dirtyVar b nc = do
+            nc <- MaybeT (inhabited (fuel - 1) dirtyVar nc)
+            b nc
+       in runMaybeT (foldr phi pure dirtySet clean)
+  where
+    clean = nc0 {dirtySet = mempty}
+
+-- | Add a formula literal to our normalized constraint set. This
+-- corresponds to fig 7.
+addLiteral ::
+  forall vt v loc m.
+  (Pmc vt v loc m) =>
+  Literal vt v loc ->
+  NormalizedConstraints vt v loc ->
+  m (Maybe (NormalizedConstraints vt v loc))
+addLiteral lit0 nabla0 = runMaybeT do
+  nc <- MaybeT $ case lit0 of
+    F -> pure Nothing
+    T -> pure (Just nabla0)
+    PosCon var datacon convars ->
+      let ctx = foldr (\(trm, typ) b -> declVar trm typ id b) nabla0 convars
+          c = C.PosCon var datacon convars
+       in addConstraint c ctx
+    NegCon var datacon -> addConstraint (C.NegCon var datacon) nabla0
+    PosLit var lit -> addConstraint (C.PosLit var lit) nabla0
+    NegLit var lit -> addConstraint (C.NegLit var lit) nabla0
+    PosListHead listRoot n listElem listElemType -> do
+      let nabla1 = declVar listElem listElemType id nabla0
+          c = C.PosListHead listRoot n listElem
+      addConstraint c nabla1
+    PosListTail listRoot n listElem listElemType -> do
+      let nabla1 = declVar listElem listElemType id nabla0
+          c = C.PosListTail listRoot n listElem
+      addConstraint c nabla1
+    NegListInterval listVar iset -> addConstraint (C.NegListInterval listVar iset) nabla0
+    Effectful var -> addConstraint (C.Effectful var) nabla0
+    Let var _expr typ -> pure (Just (declVar var typ id nabla0))
+  MaybeT (ensureInhabited initFuel nc)
+
+insertVarInfo ::
+  forall vt v loc.
+  (Ord v) =>
+  v ->
+  VarInfo vt v loc ->
+  NormalizedConstraints vt v loc ->
+  NormalizedConstraints vt v loc
+insertVarInfo k v nc@NormalizedConstraints {constraintMap} =
+  nc {constraintMap = UFMap.insert k v constraintMap}
+
+-- | Add a constraint to our normalized constraint set. This
+-- corresponds to fig 7.
+addConstraint ::
+  forall vt v loc m.
+  (Pmc vt v loc m) =>
+  Constraint vt v loc ->
+  NormalizedConstraints vt v loc ->
+  m (Maybe (NormalizedConstraints vt v loc))
+addConstraint con0 nc =
+  debugConstraint <$> case con0 of
+    C.PosLit var pmlit ->
+      let updateLiteral pos neg lit
+            | Just lit1 <- pos,
+              lit1 == lit = case lit1 == lit of
+                -- we already have this positive constraint
+                True -> (pure (), Ignore)
+                -- contradicts positive info
+                False -> (contradiction, Ignore)
+            -- the constraint contradicts negative info
+            | Set.member lit neg = (contradiction, Ignore)
+            | otherwise = (pure (), Update (Just lit, neg))
+       in modifyLiteralC var pmlit updateLiteral nc
+    C.NegLit var pmlit ->
+      let updateLiteral pos neg lit
+            -- the constraint contradicts positive info
+            | Just lit1 <- pos, lit1 == lit = (contradiction, Ignore)
+            -- we already have this negative constraint
+            | Set.member lit neg = (pure (), Ignore)
+            | otherwise = (pure (), Update (pos, Set.insert lit neg))
+       in modifyLiteralC var pmlit updateLiteral nc
+    C.NegListInterval var negMatchInterval ->
+      let updateList _typ pCons pSnoc posMatchInterval
+            -- No lengths are accepted
+            | IntervalSet.null newMatchInterval = (contradiction, Ignore)
+            -- This length constraint forces equating some cons and snoc matches
+            | let unconflictedLen = length pCons + length pSnoc,
+              Just maxLen <- IntervalSet.lookupMax newMatchInterval,
+              maxLen < unconflictedLen =
+                let varsToEquate = unconflictedLen - maxLen
+                    (newPSnoc, vars) =
+                      let (_as, bs) = Seq.splitAt (length pCons - varsToEquate) pCons
+                          (cs, ds) = Seq.splitAt (length pSnoc - varsToEquate) pSnoc
+                       in (cs, zip (toList bs) (toList ds))
+                 in (equate vars, Update (pCons, newPSnoc, newMatchInterval))
+            | otherwise =
+                (populateCons var pCons newMatchInterval, Update (pCons, pSnoc, newMatchInterval))
+            where
+              newMatchInterval = IntervalSet.difference posMatchInterval negMatchInterval
+       in modifyListC var updateList nc
+    C.PosListHead r n e ->
+      let updateList _elmType posCons posSnocs iset
+            -- there is an existing positive constraint on this element
+            | Just existingElemVar <- Seq.lookup n posCons = (equate [(e, existingElemVar)], Ignore)
+            -- a list of this length is proscribed
+            | let minPatLen = length posCons + 1,
+              Just maxLen <- IntervalSet.lookupMax iset,
+              maxLen < minPatLen =
+                (contradiction, Ignore)
+            -- the length constraint forces us to equate some cons and snoc patterns
+            | let unconflictedLen = length posCons + length posSnocs + 1,
+              Just maxLen <- IntervalSet.lookupMax iset,
+              maxLen < unconflictedLen =
+                let posCons' = posCons Seq.|> e
+                    e' = Seq.index posSnocs (maxLen - length posCons')
+                 in (equate [(e, e')], Update (posCons', posSnocs, iset))
+            | otherwise =
+                let posCons' = posCons Seq.|> e
+                    iset' = IntervalSet.delete (0, length posCons' - 1) iset
+                 in (pure (), Update (posCons', posSnocs, iset'))
+       in modifyListC r updateList nc
+    C.PosListTail r n e ->
+      let updateList _elmType posCons posSnoc iset
+            -- there is an existing positive constraint on this element
+            | Just existingElemVar <- Seq.lookup n posSnoc = (equate [(e, existingElemVar)], Ignore)
+            -- a list of this length is proscribed
+            | let minPatLen = length posSnoc + 1,
+              Just maxLen <- IntervalSet.lookupMax iset,
+              maxLen < minPatLen =
+                (contradiction, Ignore)
+            -- the length constraint forces us to equate some cons and snoc patterns
+            | let unconflictedLen = length posCons + length posSnoc + 1,
+              Just maxLen <- IntervalSet.lookupMax iset,
+              maxLen < unconflictedLen =
+                let posSnoc' = posSnoc Seq.|> e
+                    e' = Seq.index posCons (maxLen - length posSnoc')
+                 in (equate [(e, e')], Update (posCons, posSnoc', iset))
+            | otherwise =
+                let posSnoc' = posSnoc Seq.|> e
+                    iset' = IntervalSet.delete (0, length posSnoc' - 1) iset
+                 in (populateCons r posCons iset', Update (posCons, posSnoc', iset'))
+       in modifyListC r updateList nc
+    C.PosCon var datacon convars ->
+      let updateConstructor pos neg
+            | Just (datacon1, convars1) <- pos = case datacon == datacon1 of
+                True -> do
+                  -- we already have an assertion, so equate convars
+                  let varsToEquate = zipWith (\(y, _) (z, _) -> (y, z)) convars convars1
+                  (equate varsToEquate, Ignore)
+                False -> (contradiction, Ignore)
+            -- contradicts negative info
+            | True <- Set.member datacon neg = (contradiction, Ignore)
+            | otherwise =
+                -- no conflicting info, add constraint
+                (pure (), Update (Just (datacon, convars), neg))
+       in modifyConstructorC var updateConstructor nc -- runC nc (put =<< modifyConstructor var updateConstructor =<< get)
+    C.NegCon var datacon ->
+      let updateConstructor pos neg
+            -- contradicts positive info
+            | Just (datacon1, _) <- pos, datacon1 == datacon = (contradiction, Ignore)
+            -- we already have this negative constraint
+            | Set.member datacon neg = (pure (), Ignore)
+            | otherwise = (pure (), Update (pos, Set.insert datacon neg))
+       in modifyConstructorC var updateConstructor nc
+    C.Effectful var ->
+      case expectCanon var nc of
+        (var, vi, nc)
+          | otherwise -> pure $ Just $ insertVarInfo var vi {vi_eff = IsEffectful} nc
+    C.Eq x y -> union x y nc
+  where
+    debugConstraint x =
+      let debugOutput =
+            P.sep
+              "\n"
+              [ P.hang (P.red "input constraints: ") (prettyNormalizedConstraints nc),
+                P.hang (P.yellow "additional constraint: ") (C.prettyConstraint con0),
+                P.hang (P.green "resulting constraint: ") (maybe "contradiction" prettyNormalizedConstraints x),
+                ""
+              ]
+       in if shouldDebug PatternCoverageConstraintSolver then trace (P.toAnsiUnbroken debugOutput) x else x
+
+-- | Like 'addConstraint', but for a list of constraints
+addConstraints ::
+  forall vt v loc m.
+  (Pmc vt v loc m) =>
+  [Constraint vt v loc] ->
+  NormalizedConstraints vt v loc ->
+  m (Maybe (NormalizedConstraints vt v loc))
+addConstraints cs nc0 = runMaybeT $ foldlM (\b a -> MaybeT (addConstraint a b)) nc0 cs
+
+-- | Equate two variables
+union ::
+  forall vt v loc m.
+  (Pmc vt v loc m) =>
+  v ->
+  v ->
+  NormalizedConstraints vt v loc ->
+  m (Maybe (NormalizedConstraints vt v loc))
+union v0 v1 nc@NormalizedConstraints {constraintMap} =
+  UFMap.union v0 v1 constraintMap \chosenCanon nonCanonValue m ->
+    -- In this block we want to collect the constraints from the
+    -- non-canonical value and add them to the canonical value.
+
+    -- literals are handled uniformly
+    let handleLit :: forall x. (x -> PmLit) -> Maybe x -> Set x -> ([Constraint vt v loc], [Constraint vt v loc])
+        handleLit toPmLit pos neg =
+          let posC = case pos of
+                Nothing -> []
+                Just lit -> [C.PosLit chosenCanon (toPmLit lit)]
+              negC = foldr (\a b -> C.NegLit chosenCanon (toPmLit a) : b) [] neg
+           in (posC, negC)
+        constraints = posCon ++ negCon ++ effCon
+        (posCon, negCon) = case vi_con nonCanonValue of
+          Vc'Constructor pos neg ->
+            let posC = case pos of
+                  Nothing -> []
+                  Just (datacon, convars) -> [C.PosCon chosenCanon datacon convars]
+                negC = foldr (\a b -> C.NegCon chosenCanon a : b) [] neg
+             in (posC, negC)
+          Vc'ListRoot _typ posCons posSnoc iset ->
+            let consConstraints = map (\(i, x) -> C.PosListHead chosenCanon i x) (zip [0 ..] (toList posCons))
+                snocConstraints = map (\(i, x) -> C.PosListTail chosenCanon i x) (zip [0 ..] (toList posSnoc))
+                neg = [C.NegListInterval chosenCanon (IntervalSet.complement iset)]
+             in (consConstraints ++ snocConstraints, neg)
+          Vc'Boolean pos neg -> handleLit PmLit.Boolean pos neg
+          Vc'Int pos neg -> handleLit PmLit.Int pos neg
+          Vc'Nat pos neg -> handleLit PmLit.Nat pos neg
+          Vc'Float pos neg -> handleLit PmLit.Float pos neg
+          Vc'Text pos neg -> handleLit PmLit.Text pos neg
+          Vc'Char pos neg -> handleLit PmLit.Char pos neg
+        effCon = case vi_eff nonCanonValue of
+          IsNotEffectful -> []
+          IsEffectful -> [C.Effectful chosenCanon]
+     in addConstraints constraints nc {constraintMap = m}
+
+modifyListC ::
+  forall vt v loc m.
+  (Pmc vt v loc m) =>
+  v ->
+  ( Type vt loc ->
+    Seq v ->
+    Seq v ->
+    IntervalSet ->
+    (C vt v loc m (), ConstraintUpdate (Seq v, Seq v, IntervalSet))
+  ) ->
+  NormalizedConstraints vt v loc ->
+  m (Maybe (NormalizedConstraints vt v loc))
+modifyListC v f nc0 =
+  let (ccomp, nc1) = modifyListF v f nc0
+   in fmap snd <$> runC nc1 ccomp
+
+modifyListF ::
+  forall vt v loc f.
+  (Var v, Functor f) =>
+  v ->
+  ( Type vt loc ->
+    Seq v ->
+    Seq v ->
+    IntervalSet ->
+    f (ConstraintUpdate (Seq v, Seq v, IntervalSet))
+  ) ->
+  NormalizedConstraints vt v loc ->
+  f (NormalizedConstraints vt v loc)
+modifyListF v f nc =
+  let g vc = getCompose (posAndNegList (\typ pcons psnoc iset -> Compose (f typ pcons psnoc iset)) vc)
+   in modifyVarConstraints v g nc
+
+modifyConstructorC ::
+  forall vt v loc m.
+  (Pmc vt v loc m) =>
+  v ->
+  ( (Maybe (ConstructorReference, [(v, Type vt loc)])) ->
+    Set ConstructorReference ->
+    (C vt v loc m (), ConstraintUpdate (Maybe (ConstructorReference, [(v, Type vt loc)]), Set ConstructorReference))
+  ) ->
+  NormalizedConstraints vt v loc ->
+  m (Maybe (NormalizedConstraints vt v loc))
+modifyConstructorC v f nc0 =
+  let (ccomp, nc1) = modifyConstructorF v f nc0
+   in fmap snd <$> runC nc1 ccomp
+
+modifyConstructorF ::
+  forall vt v loc f.
+  (Var v, Functor f) =>
+  v ->
+  ( (Maybe (ConstructorReference, [(v, Type vt loc)])) ->
+    Set ConstructorReference ->
+    f (ConstraintUpdate (Maybe (ConstructorReference, [(v, Type vt loc)]), Set ConstructorReference))
+  ) ->
+  NormalizedConstraints vt v loc ->
+  f (NormalizedConstraints vt v loc)
+modifyConstructorF v f nc =
+  let g vc = getCompose (posAndNegConstructor (\pos neg -> Compose (f pos neg)) vc)
+   in modifyVarConstraints v g nc
+
+modifyLiteralC ::
+  forall vt v loc m.
+  (Pmc vt v loc m) =>
+  v ->
+  PmLit ->
+  ( forall a.
+    (Ord a) =>
+    -- positive info
+    Maybe a ->
+    -- negative info
+    Set a ->
+    -- the passed in PmLit, unpacked
+    a ->
+    (C vt v loc m (), ConstraintUpdate (Maybe a, Set a))
+  ) ->
+  NormalizedConstraints vt v loc ->
+  m (Maybe (NormalizedConstraints vt v loc))
+modifyLiteralC v lit f nc0 =
+  let (ccomp, nc1) = modifyLiteralF v lit f nc0
+   in fmap snd <$> runC nc1 ccomp
+
+-- | Update constraints on some literal by only depending on their Ord
+-- instance.
+modifyLiteralF ::
+  forall vt v loc f.
+  (Var v, Functor f) =>
+  v ->
+  PmLit ->
+  ( forall a.
+    (Ord a) =>
+    -- positive info
+    Maybe a ->
+    -- negative info
+    Set a ->
+    -- the passed in PmLit, unpacked
+    a ->
+    f (ConstraintUpdate (Maybe a, Set a))
+  ) ->
+  NormalizedConstraints vt v loc ->
+  f (NormalizedConstraints vt v loc)
+modifyLiteralF v lit f nc =
+  let g vc = getCompose (posAndNegLiteral (\pos neg candidate -> Compose (f pos neg candidate)) lit vc)
+   in modifyVarConstraints v g nc
+
+modifyVarConstraints ::
+  forall vt v loc f.
+  (Var v, Functor f) =>
+  v ->
+  ( VarConstraints vt v loc ->
+    f (ConstraintUpdate (VarConstraints vt v loc))
+  ) ->
+  NormalizedConstraints vt v loc ->
+  -- | applied to 'Vc'Constructor'
+  f (NormalizedConstraints vt v loc)
+modifyVarConstraints v updateVarConstraint nc0 = do
+  updateF v (\_v vi -> fmap (\vc -> vi {vi_con = vc}) <$> updateVarConstraint (vi_con vi)) nc0
+{-# INLINE modifyVarConstraints #-}
+
+-- | Modify the positive and negative constraints of a constructor.
+posAndNegConstructor ::
+  forall f vt v loc.
+  (Functor f) =>
+  ( (Maybe (ConstructorReference, [(v, Type vt loc)])) ->
+    Set ConstructorReference ->
+    f (Maybe (ConstructorReference, [(v, Type vt loc)]), Set ConstructorReference)
+  ) ->
+  VarConstraints vt v loc ->
+  f (VarConstraints vt v loc)
+posAndNegConstructor f = \case
+  Vc'Constructor pos neg -> uncurry Vc'Constructor <$> f pos neg
+  _ -> error "impossible: posAndNegConstructor called on a literal"
+{-# INLINE posAndNegConstructor #-}
+
+-- | Modify the positive and negative constraints in a way that
+-- doesn't rely upon the particular literal type, but only on it being
+-- an instance of Ord.
+posAndNegLiteral ::
+  forall f vt v loc.
+  (Functor f) =>
+  ( forall a.
+    (Ord a) =>
+    Maybe a ->
+    Set a ->
+    a ->
+    f (Maybe a, Set a)
+  ) ->
+  PmLit ->
+  VarConstraints vt v loc ->
+  f (VarConstraints vt v loc)
+posAndNegLiteral f lit = \case
+  Vc'Boolean pos neg
+    | PmLit.Boolean b <- lit -> uncurry Vc'Boolean <$> f pos neg b
+  Vc'Int pos neg
+    | PmLit.Int b <- lit -> uncurry Vc'Int <$> f pos neg b
+  Vc'Nat pos neg
+    | PmLit.Nat b <- lit -> uncurry Vc'Nat <$> f pos neg b
+  Vc'Float pos neg
+    | PmLit.Float b <- lit -> uncurry Vc'Float <$> f pos neg b
+  Vc'Text pos neg
+    | PmLit.Text b <- lit -> uncurry Vc'Text <$> f pos neg b
+  Vc'Char pos neg
+    | PmLit.Char b <- lit -> uncurry Vc'Char <$> f pos neg b
+  Vc'Constructor _ _ -> error "impossible: posAndNegLiteral called on constructor"
+  _ -> error "impossible: incompatible PmLit and VarConstraints types"
+{-# INLINE posAndNegLiteral #-}
+
+posAndNegList ::
+  forall f vt v loc.
+  (Functor f) =>
+  ( Type vt loc ->
+    Seq v ->
+    Seq v ->
+    IntervalSet ->
+    f (Seq v, Seq v, IntervalSet)
+  ) ->
+  VarConstraints vt v loc ->
+  f (VarConstraints vt v loc)
+posAndNegList f = \case
+  Vc'ListRoot typ posCons posSnocs iset -> (\(posCons, posSnocs, iset) -> Vc'ListRoot typ posCons posSnocs iset) <$> f typ posCons posSnocs iset
+  _ -> error "impossible: posAndNegList called on a something that isn't a list"
+{-# INLINE posAndNegList #-}
+
+newtype C vt v loc m a = C
+  { unC ::
+      NormalizedConstraints vt v loc ->
+      m (Maybe (a, NormalizedConstraints vt v loc))
+  }
+  deriving
+    (Functor, Applicative, Monad, MonadState (NormalizedConstraints vt v loc))
+    via StateT (NormalizedConstraints vt v loc) (MaybeT m)
+  deriving (MonadTrans) via ComposeT (StateT (NormalizedConstraints vt v loc)) MaybeT
+
+contradiction :: (Applicative m) => C vt v loc m a
+contradiction = C \_ -> pure Nothing
+
+equate :: (Pmc vt v loc m) => [(v, v)] -> C vt v loc m ()
+equate vs = addConstraintsC (map (uncurry C.Eq) vs)
+
+lookupListElemTypeC :: (Pmc vt v loc m) => v -> C vt v loc m (Type vt loc)
+lookupListElemTypeC listVar = do
+  nc0 <- get
+  let (_var, vi, nc1) = expectCanon listVar nc0
+  put nc1
+  pure $ getConst (posAndNegList (\elemTyp _ _ _ -> Const elemTyp) (vi_con vi))
+
+addConstraintsC :: (Pmc vt v loc m) => [Constraint vt v loc] -> C vt v loc m ()
+addConstraintsC cs = do
+  nc <- get
+  lift (addConstraints cs nc) >>= \case
+    Nothing -> contradiction
+    Just nc -> put nc
+
+declVarC ::
+  (Pmc vt v loc m) =>
+  v ->
+  Type vt loc ->
+  (VarInfo vt v loc -> VarInfo vt v loc) ->
+  C vt v loc m ()
+declVarC v vt vimod = do
+  nc0 <- get
+  let nc1 = declVar v vt vimod nc0
+  put nc1
+
+freshC ::
+  (Pmc vt v loc m) =>
+  C vt v loc m v
+freshC = lift fresh
+
+populateCons :: (Pmc vt v loc m) => v -> Seq v -> IntervalSet -> C vt v loc m ()
+populateCons listVar pCons iset = do
+  case IntervalSet.lookupMin iset of
+    Just minLen
+      | minLen > 0,
+        let targets = [length pCons .. minLen - 1],
+        not (null targets) -> do
+          elemTyp <- lookupListElemTypeC listVar
+          for_ targets \idx -> do
+            elv <- freshC
+            declVarC elv elemTyp id
+            addConstraintsC [C.PosListHead listVar idx elv]
+    _ -> pure ()
+
+runC ::
+  (Applicative m) =>
+  NormalizedConstraints vt v loc ->
+  C vt v loc m a ->
+  m (Maybe (a, NormalizedConstraints vt v loc))
+runC nc0 ca = unC ca nc0

parser-typechecker/src/Unison/PatternMatchCoverage/UFMap.hs

@@ -0,0 +1,243 @@
+{-# LANGUAGE RecursiveDo #-}
+
+module Unison.PatternMatchCoverage.UFMap
+  ( UFMap,
+    UFValue (..),
+    empty,
+    lookupCanon,
+    insert,
+    union,
+    alterF,
+    alter,
+    keys,
+    toClasses,
+  )
+where
+
+import Control.Monad.Fix (MonadFix)
+import Control.Monad.Trans.Except (ExceptT (..))
+import Data.Foldable (foldl')
+import Data.Functor ((<&>))
+import Data.Functor.Compose (Compose (..))
+import Data.Functor.Identity (Identity (Identity, runIdentity))
+import Data.Functor.Sum (Sum (..))
+import Data.Map (Map)
+import qualified Data.Map.Lazy as LazyMap
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromJust)
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+-- | A union-find structure. Used by
+-- 'Unison.PatternMatchCoverage.NormalizedConstraints.NormalizedConstraints'
+-- to provide efficient unification.
+newtype UFMap k v = UFMap (Map k (UFValue k v))
+  deriving stock (Eq, Ord, Show)
+
+data UFValue k v
+  = -- | This is not the canonical value, lookup k in the map to try again
+    Indirection !k
+  | -- | The number of elements in the equivalence class
+    Canonical !Int !v
+  deriving stock (Eq, Ord, Show)
+
+empty :: UFMap k v
+empty = UFMap Map.empty
+
+insert :: (Ord k) => k -> v -> UFMap k v -> UFMap k v
+insert k !v m =
+  alter k (Just v) (\_ s _ -> Canonical s v) m
+
+alterF' ::
+  forall f k v.
+  (Functor f, Ord k) =>
+  -- | The key to lookup
+  k ->
+  -- | The canonical key (use laziness to supply if unknown)
+  k ->
+  -- | Return Just to short-circuit the indirection lookup loop
+  (k -> UFMap k v -> Maybe (f (UFMap k v))) ->
+  -- | Nothing case
+  f (Maybe v) ->
+  -- | Just case
+  --
+  -- @canonicalKey -> size -> value -> new value@
+  --
+  -- /N.B./ deleting a value is not supported
+  (k -> Int -> v -> f (UFValue k v)) ->
+  UFMap k v ->
+  -- | Returns the canonical k, the size, the value, and the path
+  -- compressed UFMap
+  f (UFMap k v)
+alterF' k0 kcanon loopGuard handleNothing handleJust map0 =
+  let phi :: k -> Maybe (UFValue k v) -> Sum ((,) k) f (Maybe (UFValue k v))
+      phi k =
+        \case
+          Nothing -> InR (fmap (Canonical 1) <$> handleNothing)
+          Just alpha -> case alpha of
+            Indirection k -> InL (k, Just (Indirection kcanon))
+            Canonical sizeOrig v -> InR (Just <$> handleJust k sizeOrig v)
+      go :: k -> UFMap k v -> f (UFMap k v)
+      go k ufm@(UFMap m) = case loopGuard k ufm of
+        Just short -> short
+        Nothing -> case LazyMap.alterF (phi k) k m of
+          InL (k, m') -> go k (UFMap m')
+          InR res -> UFMap <$> res
+   in go k0 map0
+{-# INLINE alterF' #-}
+
+alterFWithHalt ::
+  forall f k v.
+  (Functor f, Ord k) =>
+  k ->
+  (k -> UFMap k v -> Maybe (f (UFMap k v))) ->
+  f (Maybe v) ->
+  (k -> Int -> v -> f (UFValue k v)) ->
+  UFMap k v ->
+  f (UFMap k v)
+alterFWithHalt k0 isCanonical handleNothing handleJust map0 =
+  -- tie the canonicalK knot
+  let (canonicalK, res) = getCompose (alterF' k0 canonicalK loopGuard handleNothing' handleJust' map0)
+      handleNothing' = Compose (k0, handleNothing)
+      handleJust' k s v = Compose (k, handleJust k s v)
+      -- if the key is canonical then we halt and return it as the
+      -- left element of the tuple
+      loopGuard k m = Compose . (k,) <$> isCanonical k m
+   in res
+{-# INLINE alterFWithHalt #-}
+
+alterF ::
+  forall f k v.
+  (Functor f, Ord k) =>
+  k ->
+  f (Maybe v) ->
+  (k -> Int -> v -> f (UFValue k v)) ->
+  UFMap k v ->
+  f (UFMap k v)
+alterF k = alterFWithHalt k (\_ _ -> Nothing)
+{-# INLINE alterF #-}
+
+alter ::
+  forall k v.
+  (Ord k) =>
+  k ->
+  Maybe v ->
+  (k -> Int -> v -> UFValue k v) ->
+  UFMap k v ->
+  UFMap k v
+alter k handleNothing handleJust map0 =
+  runIdentity (alterF k (Identity handleNothing) (\k s v -> Identity (handleJust k s v)) map0)
+
+-- | Lookup the canonical value
+lookupCanon ::
+  (Ord k) =>
+  k ->
+  UFMap k v ->
+  -- | returns:
+  --
+  -- * the canonical member of the equivalence set
+  -- * the size of the equivalence set
+  -- * the associated value
+  -- * the @UFMap@ after path compression
+  Maybe (k, Int, v, UFMap k v)
+lookupCanon k m =
+  getCompose (alterF k nothing just m)
+  where
+    nothing = Compose Nothing
+    just k s v = Compose (Just (k, s, v, Canonical s v))
+
+data UnionHaltReason k v
+  = KeyNotFound k
+  | MergeFailed v v
+
+data UnionValue k v a
+  = UnionValue k Int v (UFValue k v) a
+  deriving stock (Functor)
+
+union ::
+  forall m k v r.
+  (MonadFix m, Ord k) =>
+  k ->
+  k ->
+  UFMap k v ->
+  (k -> v -> UFMap k v -> m (Maybe r)) ->
+  m (Maybe r)
+union k0 k1 mapinit mergeValues = toMaybe do
+  rec let lu ::
+            k ->
+            UFMap k v ->
+            (k -> UFMap k v -> Maybe (Compose (Either (UnionHaltReason k v)) (UnionValue k v) (UFMap k v))) ->
+            Either (UnionHaltReason k v) (UnionValue k v (UFMap k v))
+          lu k m loopGuard = getCompose (alterFWithHalt k loopGuard luNothing luJust m)
+            where
+              luNothing = Compose (Left (KeyNotFound k))
+          luJust k s v =
+            -- a final value thunk is inserted before it is resolved,
+            -- as the final result cannot be known before we have
+            -- looked up both values and merged them
+            let newValue =
+                  let newSize = case kcanon0 == kcanon1 of
+                        True -> size0
+                        False -> size0 + size1
+                   in case chosenCanon == k of
+                        True -> Canonical newSize canonValue
+                        False -> Indirection chosenCanon
+             in Compose (Right (UnionValue k s v newValue newValue))
+      UnionValue kcanon0 size0 v0 vfinal0 map0 <- ExceptT $ pure $ lu k0 mapinit \_ _ -> Nothing
+      UnionValue kcanon1 size1 v1 vfinal1 map1 <- ExceptT $
+        pure $ lu k1 map0 \k m -> case k == kcanon0 of
+          False -> Nothing
+          True -> Just (Compose (Right (UnionValue k size0 v0 vfinal0 m)))
+      -- Join the smaller equivalence class to the larger to bound
+      -- worst case number of lookups to log(n). This is the same
+      -- strategy as the weighted fast-union algorithm.
+      let (chosenCanon, canonValue, nonCanonValue) = case size0 > size1 of
+            True -> (kcanon0, v0, v1)
+            False -> (kcanon1, v1, v0)
+  map2 <-
+    let res =
+          ExceptT $
+            mergeValues chosenCanon nonCanonValue map1 <&> \case
+              Nothing -> Left (MergeFailed v0 v1)
+              Just x -> Right x
+     in -- Now that both lookups have completed we can safely force the
+        -- final values
+        vfinal0 `seq` vfinal1 `seq` res
+  pure map2
+  where
+    toMaybe :: ExceptT (UnionHaltReason k v) m r -> m (Maybe r)
+    toMaybe (ExceptT action) =
+      action <&> \case
+        Right m -> Just m
+        Left r -> case r of
+          KeyNotFound _k -> Nothing
+          MergeFailed _v0 _v1 -> Nothing
+
+-- | Dump the @UFmap@ to a list grouped by equivalence class
+toClasses ::
+  forall k v.
+  (Ord k) =>
+  UFMap k v ->
+  -- | [(canonical key, equivalence class, value)]
+  [(k, Set k, v)]
+toClasses m0 =
+  let cmFinal :: Map k (k, Set k, v)
+      (_mfinal, cmFinal) =
+        -- we fold over the UFMap's keys and build up a Map that
+        -- groups the keys by equivalence class.
+        foldl' buildCmFinal (m0, Map.empty) keys
+      keys = case m0 of
+        UFMap m -> Map.keys m
+      buildCmFinal (m, cm) k =
+        let (kcanon, _, v, m') = fromJust (lookupCanon k m)
+            cm' =
+              Map.insertWith
+                (\(k0, s0, v0) (_k1, s1, _v1) -> (k0, s0 <> s1, v0))
+                kcanon
+                (k, Set.singleton k, v)
+                cm
+         in (m', cm')
+   in Map.elems cmFinal
+
+keys :: UFMap k v -> [k]
+keys (UFMap m) = Map.keys m

parser-typechecker/src/Unison/PrintError.hs

@@ -28,6 +28,7 @@ import qualified Unison.Names as Names
 import qualified Unison.Names.ResolutionResult as Names
 import qualified Unison.NamesWithHistory as NamesWithHistory
 import Unison.Parser.Ann (Ann (..))
+import Unison.Pattern (Pattern)
 import Unison.Prelude
 import qualified Unison.PrettyPrintEnv as PPE
 import qualified Unison.PrettyPrintEnv.Names as PPE
@@ -36,6 +37,7 @@ import Unison.Referent (Referent, pattern Ref)
 import Unison.Result (Note (..))
 import qualified Unison.Result as Result
 import qualified Unison.Settings as Settings
+import Unison.Symbol (Symbol)
 import qualified Unison.Syntax.HashQualified as HQ (toString)
 import qualified Unison.Syntax.Lexer as L
 import qualified Unison.Syntax.Name as Name (toText)
@@ -591,6 +593,22 @@ renderTypeError e env src curPath = case e of
                   <> annotatedAsErrorSite src typeSite,
         "Make sure it's imported and spelled correctly."
       ]
+  UncoveredPatterns loc tms ->
+    mconcat
+      [ Pr.hang
+          "Pattern match doesn't cover all possible cases:"
+          (annotatedAsErrorSite src loc),
+        "\n\n"
+      ]
+      <> Pr.hang
+        "Patterns not matched:\n"
+        ( Pr.bulleted
+            (map (\x -> Pr.lit (renderPattern env x)) (Nel.toList tms))
+        )
+  RedundantPattern loc ->
+    Pr.hang
+      "This case would be ignored because it's already covered by the preceding case(s):"
+      (annotatedAsErrorSite src loc)
   UnknownTerm {..} ->
     let (correct, wrongTypes, wrongNames) =
           foldr sep id suggestions ([], [], [])
@@ -809,6 +827,26 @@ renderTypeError e env src curPath = case e of
     --     C.InMatchBody     -> "InMatchBody"
     simpleCause :: C.Cause v loc -> Pretty ColorText
     simpleCause = \case
+      C.UncoveredPatterns loc tms ->
+        mconcat
+          [ "Incomplete pattern matches:\n",
+            annotatedAsErrorSite src loc,
+            "\n\n",
+            "Uncovered cases:\n"
+          ]
+          <> Pr.sep "\n" (map (\x -> Pr.lit (renderPattern env x)) (Nel.toList tms))
+      C.RedundantPattern loc ->
+        mconcat
+          [ "Redundant pattern match: ",
+            "\n",
+            annotatedAsErrorSite src loc
+          ]
+      C.InaccessiblePattern loc ->
+        mconcat
+          [ "Inaccessible pattern match: ",
+            "\n",
+            annotatedAsErrorSite src loc
+          ]
       C.TypeMismatch c ->
         mconcat ["TypeMismatch\n", "  context:\n", renderContext env c]
       C.HandlerOfUnexpectedType loc typ ->
@@ -935,7 +973,7 @@ renderCompilerBug env _src bug = mconcat $ case bug of
         C.Data -> "  data type"
         C.Effect -> "  ability",
       "\n",
-      "  reerence = ",
+      "  reference = ",
       showTypeRef env rf
     ]
   C.UnknownConstructor sort (ConstructorReference rf i) _decl ->
@@ -1019,13 +1057,16 @@ renderContext env ctx@(C.Context es) =
       shortName v <> " : " <> renderType' env (C.apply ctx t)
     showElem _ (C.Marker v) = "|" <> shortName v <> "|"
 
-renderTerm :: (IsString s, Var v) => Env -> C.Term v loc -> s
+renderTerm :: (IsString s, Var v) => Env -> Term.Term' (TypeVar.TypeVar loc0 v) v loc1 -> s
 renderTerm env e =
   let s = Color.toPlain $ TermPrinter.pretty' (Just 80) env (TypeVar.lowerTerm e)
    in if length s > Settings.renderTermMaxLength
         then fromString (take Settings.renderTermMaxLength s <> "...")
         else fromString s
 
+renderPattern :: Env -> Pattern ann -> ColorText
+renderPattern env e = Pr.renderUnbroken . Pr.syntaxToColor . fst $ TermPrinter.prettyPattern env TermPrinter.emptyAc 0 ([] :: [Symbol]) e
+
 -- | renders a type with no special styling
 renderType' :: (IsString s, Var v) => Env -> Type v loc -> s
 renderType' env typ =

parser-typechecker/src/Unison/Runtime/IOSource.hs

@@ -7,18 +7,23 @@ import Control.Lens (view, _1)
 import Control.Monad.Morph (hoist)
 import Data.List (elemIndex, genericIndex)
 import qualified Data.Map as Map
-import Debug.RecoverRTTI (anythingToString)
+import qualified Data.Text as Text
 import Text.RawString.QQ (r)
 import qualified Unison.Builtin as Builtin
 import Unison.Codebase.CodeLookup (CodeLookup (..))
 import qualified Unison.Codebase.CodeLookup.Util as CL
+import qualified Unison.Codebase.Path as Path
 import Unison.ConstructorReference (GConstructorReference (..))
 import qualified Unison.DataDeclaration as DD
 import qualified Unison.DataDeclaration.ConstructorId as DD
 import Unison.FileParsers (parseAndSynthesizeFile)
 import qualified Unison.NamesWithHistory as Names
+import qualified Unison.NamesWithHistory as NamesWithHistory
 import Unison.Parser.Ann (Ann (..))
 import Unison.Prelude
+import qualified Unison.PrettyPrintEnv as PPE
+import qualified Unison.PrettyPrintEnv.Names as PPE
+import qualified Unison.PrintError as PrintError
 import qualified Unison.Reference as R
 import qualified Unison.Result as Result
 import Unison.Symbol (Symbol)
@@ -26,6 +31,8 @@ import qualified Unison.Syntax.Parser as Parser
 import qualified Unison.Term as Term
 import qualified Unison.Typechecker.TypeLookup as TL
 import qualified Unison.UnisonFile as UF
+import qualified Unison.UnisonFile.Names as UF
+import Unison.Util.Monoid (intercalateMap)
 import qualified Unison.Var as Var
 
 debug :: Bool
@@ -42,10 +49,9 @@ typecheckedFile' =
       tl = const $ pure (External <$ Builtin.typeLookup)
       env = Parser.ParsingEnv mempty (Names.NamesWithHistory Builtin.names0 mempty)
       r = parseAndSynthesizeFile [] tl env "<IO.u builtin>" source
-   in case runIdentity $ Result.runResultT r of
-        (Nothing, notes) -> error $ "parsing failed: " <> anythingToString (toList notes)
-        (Just Left {}, notes) -> error $ "typechecking failed" <> anythingToString (toList notes)
-        (Just (Right file), _) -> file
+   in case decodeResult (Text.unpack source) r of
+        Left str -> error str
+        Right file -> file
 
 typecheckedFileTerms :: Map.Map Symbol R.Reference
 typecheckedFileTerms = view _1 <$> UF.hashTerms typecheckedFile
@@ -708,6 +714,7 @@ Pretty.map f p =
     Lit _ t -> Lit () (f t)
     Wrap _ p -> Wrap () (go p)
     OrElse _ p1 p2 -> OrElse () (go p1) (go p2)
+    Table _ xs -> Table () (List.map (List.map go) xs)
     Indent _ i0 iN p -> Indent () (go i0) (go iN) (go p)
     Annotated.Append _ ps -> Annotated.Append () (List.map go ps)
   Pretty (go (Pretty.get p))
@@ -959,3 +966,38 @@ syntax.docFormatConsole d =
     Special sf -> Pretty.lit (Left sf)
   go d
 |]
+
+type Note = Result.Note Symbol Ann
+
+type TFile = UF.TypecheckedUnisonFile Symbol Ann
+
+type SynthResult =
+  Result.Result
+    (Seq Note)
+    (Either (UF.UnisonFile Symbol Ann) TFile)
+
+type EitherResult = Either String TFile
+
+showNotes :: (Foldable f) => String -> PrintError.Env -> f Note -> String
+showNotes source env =
+  intercalateMap "\n\n" $ PrintError.renderNoteAsANSI 60 env source Path.absoluteEmpty
+
+decodeResult ::
+  String -> SynthResult -> EitherResult
+decodeResult source (Result.Result notes Nothing) =
+  Left $ showNotes source ppEnv notes
+decodeResult source (Result.Result notes (Just (Left uf))) =
+  let errNames = UF.toNames uf
+   in Left $
+        showNotes
+          source
+          ( PPE.fromNames
+              10
+              (NamesWithHistory.shadowing errNames Builtin.names)
+          )
+          notes
+decodeResult _source (Result.Result _notes (Just (Right uf))) =
+  Right uf
+
+ppEnv :: PPE.PrettyPrintEnv
+ppEnv = PPE.fromNames 10 Builtin.names

parser-typechecker/src/Unison/Runtime/Interface.hs

@@ -151,6 +151,7 @@ recursiveDeclDeps ::
   Set RF.LabeledDependency ->
   CodeLookup Symbol IO () ->
   Decl Symbol () ->
+  -- (type deps, term deps)
   IO (Set Reference, Set Reference)
 recursiveDeclDeps seen0 cl d = do
   rec <- for (toList newDeps) $ \case
@@ -176,6 +177,7 @@ recursiveTermDeps ::
   Set RF.LabeledDependency ->
   CodeLookup Symbol IO () ->
   Term Symbol ->
+  -- (type deps, term deps)
   IO (Set Reference, Set Reference)
 recursiveTermDeps seen0 cl tm = do
   rec <- for (toList (deps \\ seen0)) $ \case

parser-typechecker/src/Unison/Syntax/TermPrinter.hs

@@ -9,12 +9,14 @@ module Unison.Syntax.TermPrinter
     prettyBindingWithoutTypeSignature,
     pretty0,
     runPretty,
+    prettyPattern,
   )
 where
 
 import Control.Lens (unsnoc, (^.))
 import Control.Monad.State (evalState)
 import qualified Control.Monad.State as State
+import Data.Char (isPrint)
 import Data.List
 import qualified Data.Map as Map
 import qualified Data.Set as Set
@@ -86,12 +88,12 @@ data AmbientContext = AmbientContext
   { -- The operator precedence of the enclosing context (a number from 0 to 11,
     -- or -1 to render without outer parentheses unconditionally).
     -- Function application has precedence 10.
-    precedence :: Int,
-    blockContext :: BlockContext,
-    infixContext :: InfixContext,
-    imports :: Imports,
-    docContext :: DocLiteralContext,
-    elideUnit :: Bool -- `True` if a `()` at the end of a block should be elided
+    precedence :: !Int,
+    blockContext :: !BlockContext,
+    infixContext :: !InfixContext,
+    imports :: !Imports,
+    docContext :: !DocLiteralContext,
+    elideUnit :: !Bool -- `True` if a `()` at the end of a block should be elided
   }
 
 -- Description of the position of this ABT node, when viewed in the
@@ -226,6 +228,24 @@ pretty0
       --      metaprograms), then it needs to be able to print them (and then the
       --      parser ought to be able to parse them, to maintain symmetry.)
       Boolean' b -> pure . fmt S.BooleanLiteral $ if b then l "true" else l "false"
+      Text' s
+        | Just quotes <- useRaw s ->
+            pure . fmt S.TextLiteral $ PP.text quotes <> "\n" <> PP.text s <> PP.text quotes
+        where
+          -- we only use this syntax if we're not wrapped in something else,
+          -- to avoid possible round trip issues if the text ends at an odd column
+          useRaw _ | p > 0 = Nothing
+          useRaw s | Text.find (== '\n') s == Just '\n' && Text.all ok s = n 3
+          useRaw _ = Nothing
+          ok ch = isPrint ch || ch == '\n' || ch == '\r'
+          -- Picks smallest number of surrounding """ to be unique
+          n 10 = Nothing -- bail at 10, avoiding quadratic behavior in weird cases
+          n cur =
+            if null (Text.breakOnAll quotes s)
+              then Just quotes
+              else n (cur + 1)
+            where
+              quotes = Text.pack (replicate cur '"')
       Text' s -> pure . fmt S.TextLiteral $ l $ U.ushow s
       Char' c -> pure
         . fmt S.CharLiteral
@@ -470,7 +490,7 @@ pretty0
                 paren (p >= 10) <$> do
                   lastArg' <- pretty0 (ac 10 Normal im doc) lastArg
                   booleanOps (fmt S.ControlKeyword "||") xs lastArg'
-              _ -> case (term, nonForcePred) of
+              _other -> case (term, nonForcePred) of
                 OverappliedBinaryAppPred' f a b r
                   | binaryOpsPred f ->
                       -- Special case for overapplied binary op
@@ -484,16 +504,20 @@ pretty0
                     f' <- pretty0 (ac 10 Normal im doc) f
                     args' <- PP.spacedTraverse (pretty0 (ac 10 Normal im doc)) args
                     pure $ f' `PP.hang` args'
-                _ -> case (term, \v -> nonUnitArgPred v && not (isDelay term)) of
+                _other -> case (term, \v -> nonUnitArgPred v && not (isDelay term)) of
                   (LamsNamedMatch' [] branches, _) -> do
                     pbs <- printCase im doc branches
                     pure . paren (p >= 3) $
                       PP.group (fmt S.ControlKeyword "cases") `PP.hang` pbs
                   LamsNamedPred' vs body -> do
-                    prettyBody <- pretty0 (ac 2 Block im doc) body
+                    prettyBody <- pretty0 (ac 2 Normal im doc) body
+                    let hang = case body of
+                          Delay' (Lets' _ _) -> PP.softHang
+                          Lets' _ _ -> PP.softHang
+                          _ -> PP.hang
                     pure . paren (p >= 3) $
-                      PP.group (varList vs <> fmt S.ControlKeyword " ->") `PP.hang` prettyBody
-                  _ -> go term
+                      PP.group (varList vs <> fmt S.ControlKeyword " ->") `hang` prettyBody
+                  _other -> go term
 
       isDelay (Delay' _) = True
       isDelay _ = False

parser-typechecker/src/Unison/Typechecker/Context.hs

@@ -42,10 +42,12 @@ where
 
 import Control.Lens (over, view, _2)
 import qualified Control.Monad.Fail as MonadFail
+import Control.Monad.Fix (MonadFix (..))
 import Control.Monad.State
   ( MonadState,
     StateT,
     evalState,
+    evalStateT,
     get,
     gets,
     put,
@@ -59,6 +61,7 @@ import qualified Data.Foldable as Foldable
 import Data.Function (on)
 import Data.List
 import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as Nel
 import qualified Data.Map as Map
 import qualified Data.Sequence as Seq
 import Data.Sequence.NonEmpty (NESeq)
@@ -81,9 +84,13 @@ import qualified Unison.DataDeclaration as DD
 import Unison.DataDeclaration.ConstructorId (ConstructorId)
 import Unison.Pattern (Pattern)
 import qualified Unison.Pattern as Pattern
+import Unison.PatternMatchCoverage (checkMatch)
+import Unison.PatternMatchCoverage.Class (EnumeratedConstructors (..), Pmc (..), traverseConstructors)
+import qualified Unison.PatternMatchCoverage.ListPat as ListPat
 import Unison.Prelude
 import qualified Unison.PrettyPrintEnv as PPE
 import Unison.Reference (Reference)
+import qualified Unison.Reference as Reference
 import Unison.Referent (Referent)
 import qualified Unison.Syntax.TypePrinter as TP
 import qualified Unison.Term as Term
@@ -173,6 +180,14 @@ instance Monad (Result v loc) where
   CompilerBug bug es is >>= _ = CompilerBug bug es is
   {-# INLINE (>>=) #-}
 
+instance MonadFix (Result v loc) where
+  mfix f =
+    let res = f theA
+        theA = case res of
+          Success _ a -> a
+          _ -> error "mfix Result: forced an unsuccessful value"
+     in res
+
 btw' :: InfoNote v loc -> Result v loc ()
 btw' note = Success (Seq.singleton note) ()
 
@@ -374,6 +389,9 @@ data Cause v loc
   | ConcatPatternWithoutConstantLength loc (Type v loc)
   | HandlerOfUnexpectedType loc (Type v loc)
   | DataEffectMismatch Unknown Reference (DataDeclaration v loc)
+  | UncoveredPatterns loc (NonEmpty (Pattern ()))
+  | RedundantPattern loc
+  | InaccessiblePattern loc
   deriving (Show)
 
 errorTerms :: ErrorNote v loc -> [Term v loc]
@@ -765,6 +783,26 @@ getEffectDeclaration r = do
 getDataConstructorType :: (Var v, Ord loc) => ConstructorReference -> M v loc (Type v loc)
 getDataConstructorType = getConstructorType' Data getDataDeclaration
 
+getDataConstructors :: (Var v) => Type v loc -> M v loc (EnumeratedConstructors (TypeVar v loc) v loc)
+getDataConstructors typ
+  | Type.Ref' r <- typ, r == Type.booleanRef = pure BooleanType
+  | Type.App' (Type.Ref' r) arg <- typ,
+    r == Type.listRef =
+      let xs =
+            [ (ListPat.Cons, [arg]),
+              (ListPat.Nil, [])
+            ]
+       in pure (SequenceType xs)
+  | Just r <- theRef = do
+      decl <- getDataDeclaration r
+      pure $ ConstructorType [(v, ConstructorReference r i, ABT.vmap TypeVar.Universal t) | (i, (v, t)) <- zip [0 ..] (DD.constructors decl)]
+  | otherwise = pure OtherType
+  where
+    theRef = case typ of
+      Type.Apps' (Type.Ref' r@Reference.DerivedId {}) _targs -> Just r
+      Type.Ref' r@Reference.DerivedId {} -> Just r
+      _ -> Nothing
+
 getEffectConstructorType :: (Var v, Ord loc) => ConstructorReference -> M v loc (Type v loc)
 getEffectConstructorType = getConstructorType' Effect go
   where
@@ -1212,6 +1250,7 @@ synthesizeWanted e
       let outputType = existential' l B.Blank outputTypev
       appendContext [existential outputTypev]
       cwant <- checkCases scrutineeType outputType cases
+      ensurePatternCoverage e scrutinee scrutineeType cases
       want <- coalesceWanted cwant swant
       ctx <- getContext
       pure $ (apply ctx outputType, want)
@@ -1219,6 +1258,61 @@ synthesizeWanted e
     l = loc e
 synthesizeWanted _e = compilerCrash PatternMatchFailure
 
+getDataConstructorsAtType :: (Ord loc, Var v) => Type v loc -> M v loc (EnumeratedConstructors (TypeVar v loc) v loc)
+getDataConstructorsAtType t0 = do
+  dataConstructors <- getDataConstructors t0
+  res <- traverseConstructors (\v cr t -> (v,cr,) <$> fixType t) dataConstructors
+  pure res
+  where
+    fixType t = do
+      t <- ungeneralize t
+      let lastT = case t of
+            Type.Arrows' xs -> last xs
+            _ -> t
+      equate t0 lastT
+      applyM t
+
+instance (Ord loc, Var v) => Pmc (TypeVar v loc) v loc (StateT (Set v) (M v loc)) where
+  getConstructors = lift . getDataConstructorsAtType
+  getConstructorVarTypes t cref@(ConstructorReference _r cid) = do
+    getConstructors t >>= \case
+      ConstructorType cs -> case drop (fromIntegral cid) cs of
+        [] -> error $ show cref <> " not found in constructor list: " <> show cs
+        (_, _, consArgs) : _ -> case consArgs of
+          Type.Arrows' xs -> pure (init xs)
+          _ -> pure []
+      BooleanType -> pure []
+      OtherType -> pure []
+      SequenceType {} -> pure []
+  fresh = do
+    vs <- get
+    let v = Var.freshIn vs (Var.typed Var.Pattern)
+    put (Set.insert v vs)
+    pure v
+
+ensurePatternCoverage ::
+  forall v loc.
+  (Ord loc, Var v) =>
+  Term v loc ->
+  Term v loc ->
+  Type v loc ->
+  [Term.MatchCase loc (Term v loc)] ->
+  MT v loc (Result v loc) ()
+ensurePatternCoverage wholeMatch _scrutinee scrutineeType cases = do
+  let matchLoc = ABT.annotation wholeMatch
+  scrutineeType <- applyM scrutineeType
+  case scrutineeType of
+    -- Don't check coverage on ability handlers yet
+    Type.Apps' (Type.Ref' r) _args | r == Type.effectRef -> pure ()
+    _ -> do
+      (redundant, _inaccessible, uncovered) <- flip evalStateT (ABT.freeVars wholeMatch) do
+        checkMatch matchLoc scrutineeType cases
+      let checkUncovered = case Nel.nonEmpty uncovered of
+            Nothing -> pure ()
+            Just xs -> failWith (UncoveredPatterns matchLoc xs)
+          checkRedundant = foldr (\a b -> failWith (RedundantPattern a) *> b) (pure ()) redundant
+      checkUncovered *> checkRedundant
+
 checkCases ::
   (Var v) =>
   (Ord loc) =>
@@ -3051,3 +3145,8 @@ instance (Monad f) => Applicative (MT v loc f) where
 instance (Monad f) => MonadState (Env v loc) (MT v loc f) where
   get = MT \_ _ env -> pure (env, env)
   put env = MT \_ _ _ -> pure ((), env)
+
+instance (MonadFix f) => MonadFix (MT v loc f) where
+  mfix f = MT \a b c ->
+    let res = mfix (\ ~(wubble, _finalenv) -> runM (f wubble) a b c)
+     in res

parser-typechecker/src/Unison/Typechecker/Extractor.hs

@@ -6,6 +6,7 @@ import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Set as Set
 import qualified Unison.Blank as B
 import Unison.ConstructorReference (ConstructorReference)
+import Unison.Pattern (Pattern)
 import Unison.Prelude hiding (whenM)
 import qualified Unison.Term as Term
 import Unison.Type (Type)
@@ -242,6 +243,18 @@ duplicateDefinitions =
     C.DuplicateDefinitions vs -> pure vs
     _ -> mzero
 
+uncoveredPatterns :: ErrorExtractor v loc (loc, NonEmpty (Pattern ()))
+uncoveredPatterns =
+  cause >>= \case
+    C.UncoveredPatterns matchLoc xs -> pure (matchLoc, xs)
+    _ -> empty
+
+redundantPattern :: ErrorExtractor v loc loc
+redundantPattern =
+  cause >>= \case
+    C.RedundantPattern patternLoc -> pure patternLoc
+    _ -> empty
+
 typeMismatch :: ErrorExtractor v loc (C.Context v loc)
 typeMismatch =
   cause >>= \case

parser-typechecker/src/Unison/Typechecker/TypeError.hs

@@ -5,6 +5,7 @@ module Unison.Typechecker.TypeError where
 import Data.Bifunctor (second)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Unison.ABT as ABT
+import Unison.Pattern (Pattern)
 import Unison.Prelude hiding (whenM)
 import Unison.Type (Type)
 import qualified Unison.Type as Type
@@ -103,6 +104,8 @@ data TypeError v loc
       { defns :: NonEmpty (v, [loc]),
         note :: C.ErrorNote v loc
       }
+  | UncoveredPatterns loc (NonEmpty (Pattern ()))
+  | RedundantPattern loc
   | Other (C.ErrorNote v loc)
   deriving (Show)
 
@@ -145,7 +148,9 @@ allErrors =
       unguardedCycle,
       unknownType,
       unknownTerm,
-      duplicateDefinitions
+      duplicateDefinitions,
+      redundantPattern,
+      uncoveredPatterns
     ]
 
 topLevelComponent :: Ex.InfoExtractor v a (TypeInfo v a)
@@ -153,6 +158,16 @@ topLevelComponent = do
   defs <- Ex.topLevelComponent
   pure $ TopLevelComponent defs
 
+redundantPattern :: Ex.ErrorExtractor v a (TypeError v a)
+redundantPattern = do
+  ploc <- Ex.redundantPattern
+  pure (RedundantPattern ploc)
+
+uncoveredPatterns :: Ex.ErrorExtractor v a (TypeError v a)
+uncoveredPatterns = do
+  (mloc, uncoveredCases) <- Ex.uncoveredPatterns
+  pure (UncoveredPatterns mloc uncoveredCases)
+
 abilityCheckFailure :: Ex.ErrorExtractor v a (TypeError v a)
 abilityCheckFailure = do
   (ambient, requested, _ctx) <- Ex.abilityCheckFailure

parser-typechecker/unison-parser-typechecker.cabal

@@ -98,6 +98,20 @@ library
       Unison.FileParsers
       Unison.Hashing.V2.Convert
       Unison.Parsers
+      Unison.PatternMatchCoverage
+      Unison.PatternMatchCoverage.Class
+      Unison.PatternMatchCoverage.Constraint
+      Unison.PatternMatchCoverage.Desugar
+      Unison.PatternMatchCoverage.Fix
+      Unison.PatternMatchCoverage.GrdTree
+      Unison.PatternMatchCoverage.IntervalSet
+      Unison.PatternMatchCoverage.ListPat
+      Unison.PatternMatchCoverage.Literal
+      Unison.PatternMatchCoverage.NormalizedConstraints
+      Unison.PatternMatchCoverage.PmGrd
+      Unison.PatternMatchCoverage.PmLit
+      Unison.PatternMatchCoverage.Solve
+      Unison.PatternMatchCoverage.UFMap
       Unison.PrettyPrintEnv
       Unison.PrettyPrintEnv.FQN
       Unison.PrettyPrintEnv.MonadPretty

scheme-libs/common/unison/boot.ss

@@ -19,13 +19,22 @@
     handle
     identity
     name
-    record-case
+    data
+    data-case
+
     request
     request-case
+    sum
+    sum-case
     unison-force)
 
   (import (rnrs)
+          (for
+            (only (unison core) syntax->list)
+            expand)
+          (only (srfi :28) format)
           (unison core)
+          (unison data)
           (unison cont)
           (unison crypto))
 
@@ -147,13 +156,19 @@
          (prompt0-at p
            (let ([v (let-marks (list (quote r) ...) (cons p h)
                       (prompt0-at p e ...))])
-             (h (list 0 v)))))]))
+             (h (make-pure v)))))]))
 
   ; wrapper that more closely matches ability requests
   (define-syntax request
     (syntax-rules ()
       [(request r t . args)
-       ((cdr (ref-mark (quote r))) (list (quote r) t . args))]))
+       (let ([rq (make-request (quote r) t (list . args))])
+         (let ([current-mark (ref-mark (quote r))])
+            (if (equal? #f current-mark)
+                (raise (condition
+                            (make-error)
+                            (make-message-condition (format "Unhandled top-level effect! ~a" (list r t . args)))))
+                ((cdr current-mark) rq))))]))
 
   ; See the explanation of `handle` for a more thorough understanding
   ; of why this is doing two control operations.
@@ -169,38 +184,6 @@
        (let ([p (car (ref-mark r))])
          (control0-at p k (control0-at p _k e ...)))]))
 
-  ; Wrapper around record-case that more closely matches request
-  ; matching. This gets around having to manage an intermediate
-  ; variable name during code emission that doesn't correspond to an
-  ; actual ANF name, which was causing variable numbering problems in
-  ; the code emitter. Hygienic macros are a much more convenient
-  ; mechanism for this.
-  (define-syntax request-case
-    (syntax-rules (pure)
-      [(request-case scrut
-         [pure (pv ...) pe ...]
-         [ability
-           [effect (ev ...) ee ...]
-           ...]
-         ...)
-
-       (record-case scrut
-         [0 (pv ...) pe ...]
-         [ability subscrut
-           (record-case subscrut
-             [effect (ev ...) ee ...]
-             ...)]
-         ...)]))
-
-  (define-record-type
-    data
-    (fields type-ref payload))
-
-  (define-syntax data-case
-    (syntax-rules ()
-      [(data-case scrut c ...)
-       (record-case (data-payload scrut) c ...)]))
-
   (define (identity x) x)
   
   ; forces something that is expected to be a thunk, defined with
@@ -209,4 +192,134 @@
   (define (unison-force x)
     (if (procedure? x) (x) x))
 
+  (define-syntax sum-case
+    (lambda (stx)
+      (define (make-case scrut-stx)
+        (lambda (cur)
+          (with-syntax ([scrut scrut-stx])
+            (syntax-case cur (else)
+              [(else e ...) #'(else e ...)]
+              [((t ...) () e ...) #'((t ...) e ...)]
+              [(t () e ...) #'((t) e ...)]
+              [((t ...) (v ...) e ...)
+               #'((t ...)
+                  (let-values
+                    ([(v ...) (apply values (sum-fields scrut))])
+                    e ...))]
+              [(t (v ...) e ...)
+               #'((t)
+                  (let-values
+                    ([(v ...) (apply values (sum-fields scrut))])
+                    e ...))]
+              [((t ...) v e ...)
+               (identifier? #'v)
+               #'((t ...)
+                  (let ([v (sum-fields scrut)])
+                    e ...))]
+              [(t v e ...)
+               (identifier? #'v)
+               #'((t)
+                  (let ([v (sum-fields scrut)])
+                    e ...))]))))
+
+      (syntax-case stx ()
+        [(sum-case scrut c ...)
+         (with-syntax
+           ([(tc ...)
+             (map (make-case #'scrut) (syntax->list #'(c ...)))])
+           #'(case (sum-tag scrut) tc ...))])))
+
+  (define-syntax data-case
+    (lambda (stx)
+      (define (make-case scrut-stx)
+        (lambda (cur)
+          (with-syntax ([scrut scrut-stx])
+            (syntax-case cur (else)
+              [(else e ...) #'(else e ...)]
+              [((t ...) () e ...) #'((t ...) e ...)]
+              [(t () e ...) #'((t) e ...)]
+              [((t ...) (v ...) e ...)
+               #'((t ...)
+                  (let-values
+                    ([(v ...) (apply values (data-fields scrut))])
+                    e ...))]
+              [(t (v ...) e ...)
+               #'((t)
+                  (let-values
+                    ([(v ...) (apply values (data-fields scrut))])
+                    e ...))]
+              [((t ...) v e ...)
+               (identifier? #'v)
+               #'((t ...)
+                  (let ([v (data-fields scrut)])
+                    e ...))]
+              [(t v e ...)
+               (identifier? #'v)
+               #'((t)
+                  (let ([v (data-fields scrut)])
+                    e ...))]))))
+      (syntax-case stx ()
+        [(data-case scrut c ...)
+         (with-syntax
+           ([(tc ...)
+             (map (make-case #'scrut) (syntax->list #'(c ...)))])
+           #'(case (data-tag scrut) tc ...))])))
+
+  (define-syntax request-case
+    (lambda (stx)
+      (define (pure-case? c)
+        (syntax-case c (pure)
+          [(pure . xs) #t]
+          [_ #f]))
+
+      (define (mk-pure scrut ps)
+        (if (null? ps)
+          #`(pure-val #,scrut)
+          (syntax-case (car ps) (pure)
+            [(pure (v) e ...)
+             #`(let ([v (pure-val #,scrut)])
+                 e ...)]
+            [(pure vs e ...)
+             (raise-syntax-error
+               #f
+               "pure cases receive exactly one variable"
+               (car ps)
+               #'vs)])))
+
+      (define (mk-req scrut-stx)
+        (lambda (stx)
+          (syntax-case stx ()
+            [(t vs e ...)
+             (with-syntax ([scrut scrut-stx])
+               #'((t) (let-values
+                        ([vs (apply values (request-fields scrut))])
+                        e ...)))])))
+
+      (define (mk-abil scrut-stx)
+        (lambda (stx)
+          (syntax-case stx ()
+            [(t sc ...)
+             (let ([sub (mk-req scrut-stx)])
+               (with-syntax
+                 ([(sc ...) (map sub (syntax->list #'(sc ...)))]
+                  [scrut scrut-stx])
+                 #'((t) (case (request-tag scrut) sc ...))))])))
+
+      (syntax-case stx ()
+        [(request-case scrut c ...)
+         (let-values
+           ([(ps as) (partition pure-case? (syntax->list #'(c ...)))])
+           (if (> 1 (length ps))
+             (raise-syntax-error
+               #f
+               "multiple pure cases in request-case"
+               stx)
+             (with-syntax
+               ([pc (mk-pure #'scrut ps)]
+                [(ac ...) (map (mk-abil #'scrut) as)])
+
+               #'(cond
+                   [(pure? scrut) pc]
+                   [else (case (request-ability scrut) ac ...)]))))])))
+
   )

scheme-libs/common/unison/data.ss

@@ -3,6 +3,30 @@
 #!r6rs
 (library (unison data)
   (export
+
+   make-data
+   data
+   data?
+   data-ref
+   data-tag
+   data-fields
+
+   make-sum
+   sum
+   sum?
+   sum-tag
+   sum-fields
+
+   make-pure
+   pure?
+   pure-val
+
+   make-request
+   request?
+   request-ability
+   request-tag
+   request-fields
+
    some
    none
    some?
@@ -23,54 +47,79 @@
 
   (import (rnrs))
 
+  (define-record-type (unison-data make-data data?)
+    (fields
+      (immutable ref data-ref)
+      (immutable tag data-tag)
+      (immutable fields data-fields)))
+
+  (define (data r t . args) (make-data r t args))
+
+  (define-record-type (unison-sum make-sum sum?)
+    (fields
+      (immutable tag sum-tag)
+      (immutable fields sum-fields)))
+
+  (define (sum t . args) (make-sum t args))
+
+  (define-record-type (unison-pure make-pure pure?)
+    (fields
+      (immutable val pure-val)))
+
+  (define-record-type (unison-request make-request request?)
+    (fields
+      (immutable ability request-ability)
+      (immutable tag request-tag)
+      (immutable fields request-fields)))
+
   ; Option a
-  (define none `(0))
+  (define none (sum 0))
 
   ; a -> Option a
-  (define (some a) `(1 ,a))
+  (define (some a) (sum 1 a))
 
   ; Option a -> Bool
-  (define (some? option) (eq? 1 (car option)))
+  (define (some? option) (eq? 1 (sum-tag option)))
 
   ; Option a -> Bool
-  (define (none? option) (eq? 0 (car option)))
+  (define (none? option) (eq? 0 (sum-tag option)))
 
   ; Option a -> a (or #f)
   (define (option-get option)
     (if
      (some? option)
-     (car (cdr option))
+     (car (sum-fields option))
      (raise "Cannot get the value of an empty option ")))
 
   ; #<void> works as well
   ; Unit
-  (define unit `(0))
+  (define unit (sum 0))
 
   ; Booleans are represented as numbers
   (define false 0)
   (define true 1)
 
   ; a -> Either b a
-  (define (right a) `(1 ,a))
+  (define (right a) (sum 1 a))
 
   ; b -> Either b a
-  (define (left b) `(0 ,b))
+  (define (left b) (sum 0 b))
 
   ; Either a b -> Boolean
-  (define (right? either) (eq? 1 (car either)))
+  (define (right? either) (eq? 1 (sum-tag either)))
 
   ; Either a b -> Boolean
-  (define (left? either) (eq? 0 (car either)))
+  (define (left? either) (eq? 0 (sum-tag either)))
 
   ; Either a b -> a | b
-  (define (either-get either) (car (cdr either)))
+  (define (either-get either) (car (sum-fields either)))
 
   ; a -> Any
-  (define (any a) `(0 ,a))
+  (define (any a) (data 'Any 0 a))
 
   ; Type -> Text -> Any -> Failure
   (define (failure typeLink msg any)
-    `(0 ,typeLink ,msg ,any))
+    (sum 0 typeLink msg any))
 
   ; Type -> Text -> a ->{Exception} b
   (define (exception typeLink msg a)

scheme-libs/common/unison/primops.ss

@@ -33,7 +33,7 @@
     unison-FOp-IO.closeFile.impl.v3
     unison-FOp-IO.openFile.impl.v3
     unison-FOp-IO.putBytes.impl.v3
-    ; unison-FOp-Text.fromUtf8.impl.v3
+    unison-FOp-Text.fromUtf8.impl.v3
     unison-FOp-Text.repeat
     unison-FOp-Text.toUtf8
     ; unison-FOp-Value.serialize
@@ -48,6 +48,15 @@
     unison-FOp-MutableArray.read
     unison-FOp-MutableArray.write
 
+    unison-FOp-MutableArray.size
+    unison-FOp-ImmutableArray.size
+
+    unison-FOp-MutableByteArray.size
+    unison-FOp-ImmutableByteArray.size
+
+    unison-FOp-MutableByteArray.length
+    unison-FOp-ImmutableByteArray.length
+
     unison-FOp-ImmutableByteArray.copyTo!
     unison-FOp-ImmutableByteArray.read8
 
@@ -55,9 +64,16 @@
     unison-FOp-MutableByteArray.write8
 
     unison-FOp-Scope.bytearray
+    unison-FOp-Scope.bytearrayOf
     unison-FOp-Scope.array
+    unison-FOp-Scope.arrayOf
     unison-FOp-Scope.ref
 
+    unison-FOp-IO.bytearray
+    unison-FOp-IO.bytearrayOf
+    unison-FOp-IO.array
+    unison-FOp-IO.arrayOf
+
     unison-FOp-IO.ref
     unison-FOp-Ref.read
     unison-FOp-Ref.write
@@ -87,6 +103,7 @@
     unison-POp-DIVN
     unison-POp-DRPB
     unison-POp-DRPS
+    unison-POp-DRPT
     unison-POp-EQLN
     unison-POp-EQLT
     unison-POp-EQLU
@@ -140,12 +157,24 @@
     unison-FOp-crypto.HashAlgorithm.Blake2s_256
     unison-FOp-crypto.HashAlgorithm.Blake2b_256
     unison-FOp-crypto.HashAlgorithm.Blake2b_512
+
+    unison-FOp-IO.clientSocket.impl.v3
+    unison-FOp-IO.closeSocket.impl.v3
+    unison-FOp-IO.socketReceive.impl.v3
+    unison-FOp-IO.socketSend.impl.v3
+    unison-FOp-IO.socketPort.impl.v3
+    unison-FOp-IO.serverSocket.impl.v3
+    unison-FOp-IO.socketAccept.impl.v3
+    unison-FOp-IO.listen.impl.v3
     )
 
   (import (rnrs)
           (unison core)
+          (unison data)
           (unison string)
           (unison crypto)
+          (unison data)
+          (unison tcp)
           (unison bytevector)
           (unison vector)
           (unison concurrent))
@@ -163,7 +192,7 @@
   (define (reify-exn thunk)
     (guard
       (e [else
-           (list 0 '() (exception->string e) e) ])
+           (sum 0 '() (exception->string e) e)])
       (thunk)))
 
   ; Core implemented primops, upon which primops-in-unison can be built.
@@ -183,7 +212,7 @@
   (define (unison-POp-DRPT n t) (istring-drop n t))
   (define (unison-POp-EQLN m n) (if (fx=? m n) 1 0))
   (define (unison-POp-EQLT s t) (if (string=? s t) 1 0))
-  (define (unison-POp-EQLU x y) (if (equal? x y) 1 0))
+  (define (unison-POp-EQLU x y) (if (universal-equal? x y) 1 0))
   (define (unison-POp-EROR fnm x)
     (let-values ([(p g) (open-string-output-port)])
       (put-string p fnm)
@@ -193,8 +222,8 @@
   (define (unison-POp-FTOT f) (number->istring f))
   (define (unison-POp-IDXB n bs) (bytevector-u8-ref bs n))
   (define (unison-POp-IDXS n l)
-    (guard (x [else (list 0)])
-      (list 1 (list-ref l n))))
+    (guard (x [else (sum 0)])
+      (sum 1 (list-ref l n))))
   (define (unison-POp-IORN m n) (fxior m n))
   (define (unison-POp-ITOT i) (signed-number->istring i))
   (define (unison-POp-LEQN m n) (if (fx<=? m n) 1 0))
@@ -217,21 +246,23 @@
   (define (unison-POp-TRCE s x)
     (display s)
     (display "\n")
+    (display x)
+    (display "\n")
     (display (describe-value x))
     (display "\n"))
   (define (unison-POp-TTON s)
     (let ([mn (string->number s)])
-      (if mn (list 1 mn) (list 0))))
+      (if mn (sum 1 mn) (sum 0))))
   (define (unison-POp-UPKT t) (string->list t))
   (define (unison-POp-VWLS l)
     (if (null? l)
-      (list 0)
-      (list 1 (car l) (cdr l))))
+      (sum 0)
+      (sum 1 (car l) (cdr l))))
   (define (unison-POp-VWRS l)
     (if (null? l)
-      (list 0)
+      (sum 0)
       (let ([r (reverse l)])
-      (list 1 (reverse (cdr l)) (car l)))))
+      (sum 1 (reverse (cdr l)) (car l)))))
 
   (define (unison-POp-XORN m n) (fxxor m n))
   (define (unison-POp-VALU c) (decode-value c))
@@ -240,7 +271,7 @@
     (begin
       (put-bytevector p bs)
       (flush-output-port p)
-      (list 1 #f)))
+      (sum 1 #f)))
 
   (define (unison-FOp-Char.toText c) (istring c))
 
@@ -255,7 +286,10 @@
       [(2) stderr]))
 
   (define (unison-FOp-IO.getArgs.impl.v1)
-    (list 1 (cdr (command-line))))
+    (sum 1 (cdr (command-line))))
+
+  (define (unison-FOp-Text.fromUtf8.impl.v3 s)
+    (right (bytevector->string s utf-8-transcoder)))
 
   (define (unison-FOp-Text.toUtf8 s)
     (string->bytevector s utf-8-transcoder))
@@ -278,14 +312,14 @@
   (define (unison-FOp-ImmutableArray.read vec i)
     (catch-array
       (lambda ()
-        (list 1 (vector-ref vec i)))))
+        (sum 1 (vector-ref vec i)))))
 
   (define (unison-FOp-ImmutableArray.copyTo! dst doff src soff n)
     (catch-array
       (lambda ()
         (let next ([i (fx1- n)])
           (if (< i 0)
-            (list 1 #f)
+            (sum 1 #f)
             (begin
               (vector-set! dst (+ doff i) (vector-ref src (+ soff i)))
               (next (fx1- i))))))))
@@ -297,24 +331,24 @@
   (define (unison-FOp-MutableArray.read src i)
     (catch-array
       (lambda ()
-        (list 1 (vector-ref src i)))))
+        (sum 1 (vector-ref src i)))))
 
   (define (unison-FOp-MutableArray.write dst i x)
     (catch-array
       (lambda ()
         (vector-set! dst i x)
-        (list 1))))
+        (sum 1))))
 
   (define (unison-FOp-ImmutableByteArray.copyTo! dst doff src soff n)
     (catch-array
       (lambda ()
         (bytevector-copy! src soff dst doff n)
-        (list 1 #f))))
+        (sum 1 #f))))
 
   (define (unison-FOp-ImmutableByteArray.read8 arr i)
     (catch-array
       (lambda ()
-        (list 1 (bytevector-u8-ref arr i)))))
+        (sum 1 (bytevector-u8-ref arr i)))))
 
   (define unison-FOp-MutableByteArray.freeze! freeze-bytevector!)
 
@@ -322,10 +356,26 @@
     (catch-array
       (lambda ()
         (bytevector-u8-set! arr i b)
-        (list 1))))
+        (sum 1))))
 
   (define (unison-FOp-Scope.bytearray n) (make-bytevector n))
+  (define (unison-FOp-IO.bytearray n) (make-bytevector n))
+
   (define (unison-FOp-Scope.array n) (make-vector n))
+  (define (unison-FOp-IO.array n) (make-vector n))
+
+  (define (unison-FOp-Scope.bytearrayOf b n) (make-bytevector n b))
+  (define (unison-FOp-IO.bytearrayOf b n) (make-bytevector n b))
+
+  (define (unison-FOp-Scope.arrayOf v n) (make-vector n v))
+  (define (unison-FOp-IO.arrayOf v n) (make-vector n v))
+
+  (define unison-FOp-MutableByteArray.length bytevector-length)
+  (define unison-FOp-ImmutableByteArray.length bytevector-length)
+  (define unison-FOp-MutableByteArray.size bytevector-length)
+  (define unison-FOp-ImmutableByteArray.size bytevector-length)
+  (define unison-FOp-MutableArray.size vector-length)
+  (define unison-FOp-ImmutableArray.size vector-length)
 
   (define (unison-POp-FORK thunk) (fork thunk))
   (define (unison-POp-TFRC thunk) (try-eval thunk))

scheme-libs/common/unison/vector.ss

@@ -6,7 +6,8 @@
     freeze-subvector)
 
   (import (rnrs)
-          (unison core))
+          (unison core)
+          (unison data))
 
   (define (freeze-subvector src off len)
     (let ([dst (make-vector len)])
@@ -14,7 +15,7 @@
         (if (< i 0)
           (begin
             (freeze-vector! dst)
-            (list 1 dst))
+            (sum 1 dst))
           (begin
             (vector-set! dst i (vector-ref src (+ off i)))
             (next (fx1- i)))))))

scheme-libs/racket/unison/core.ss

@@ -14,12 +14,15 @@
     decode-value
 
     universal-compare
+    universal-equal?
 
     fx1-
     list-head
 
+    syntax->list
+    raise-syntax-error
+
     exception->string
-    record-case
     let-marks
     ref-mark
 
@@ -37,11 +40,13 @@
                   string-copy!
                   bytes
                   with-continuation-mark
-                  continuation-mark-set-first)
+                  continuation-mark-set-first
+                  raise-syntax-error)
             (string-copy! racket-string-copy!)
             (bytes bytevector))
     (racket exn)
-    (racket unsafe ops))
+    (racket unsafe ops)
+    (unison data))
 
   (define (fx1- n) (fx- n 1))
 
@@ -66,43 +71,28 @@
       [(and (number? l) (number? r)) (if (< l r) 0 2)]
       [else (raise "universal-compare: unimplemented")]))
 
+  (define (universal-equal? l r)
+    (define (pointwise ll lr)
+      (let ([nl (null? ll)] [nr (null? lr)])
+        (cond
+          [(and nl nr) #t]
+          [(or nl nr) #f]
+          [else
+            (and (universal-equal? (car ll) (car lr))
+                 (pointwise (cdr ll) (cdr lr)))])))
+    (cond
+      [(eq? l r) 1]
+      [(and (data? l) (data? r))
+       (and
+         (eqv? (data-tag l) (data-tag r))
+         (pointwise (data-fields l) (data-fields r)))]))
+
   (define exception->string exn->string)
 
-  (define-syntax record-case
-    (lambda (stx)
-      (syntax-case stx ()
-        [(record-case scrut c ...)
-         (begin
-           (define (syntax->list stx)
-             (syntax-case stx ()
-               [() '()]
-               [(x . xs) (cons #'x (syntax->list #'xs))]))
-
-           (define (make-case cur)
-             (syntax-case cur (else)
-               [(else e ...) #'(else e ...)]
-               [((t ...) () e ...) #'((t ...) e ...)]
-               [(t () e ...) #'((t) e ...)]
-               [((t ...) (v ...) e ...)
-                #'((t ...)
-                   (let-values ([(v ...) (apply values (cdr scrut))])
-                     e ...))]
-               [(t (v ...) e ...)
-                #'((t)
-                   (let-values ([(v ...) (apply values (cdr scrut))])
-                     e ...))]
-               [((t ...) v e ...)
-                (identifier? #'v)
-                #'((t ...)
-                   (let ([v (cdr scrut)])
-                     e ...))]
-               [(t v e ...)
-                (identifier? #'v)
-                #'((t)
-                   (let ([v (cdr scrut)])
-                     e ...))]))
-           #`(case (car scrut)
-               #,@(map make-case (syntax->list #'(c ...)))))])))
+  (define (syntax->list stx)
+    (syntax-case stx ()
+      [() '()]
+      [(x . xs) (cons #'x (syntax->list #'xs))]))
 
   (define (call-with-marks rs v f)
     (cond

scheme-libs/racket/unison/crypto.rkt

@@ -2,6 +2,7 @@
 (require ffi/unsafe
          ffi/unsafe/define
          racket/exn
+         openssl/libcrypto
          )
 
 (provide (prefix-out unison-FOp-crypto.
@@ -18,10 +19,12 @@
         hmacBytes)))
 
 (define libcrypto
-    (with-handlers [[exn:fail? exn->string]] (ffi-lib "libcrypto.1.1")))
+    (with-handlers [[exn:fail? exn->string]]
+                   (ffi-lib "libcrypto" openssl-lib-versions)))
 
 (define libb2
-    (with-handlers [[exn:fail? exn->string]] (ffi-lib "libb2")))
+  (with-handlers [[exn:fail? exn->string]]
+                 (ffi-lib "libb2" '("" "1"))))
 
 (define _EVP-pointer (_cpointer 'EVP))
 

scheme-libs/racket/unison/tcp.rkt

@@ -0,0 +1,91 @@
+; TLS primitives! Supplied by openssl (libssl)
+#lang racket/base
+(require racket/exn
+         racket/match
+         racket/tcp
+         unison/data)
+
+(provide
+ (prefix-out
+  unison-FOp-IO.
+  (combine-out
+   clientSocket.impl.v3
+   closeSocket.impl.v3
+   socketReceive.impl.v3
+   socketPort.impl.v3
+   serverSocket.impl.v3
+   listen.impl.v3
+   socketAccept.impl.v3
+   socketSend.impl.v3)))
+
+(define (input socket) (car socket))
+(define (output socket) (car (cdr socket)))
+
+(define (closeSocket.impl.v3 socket)
+  (if (pair? socket)
+      (begin
+        (close-input-port (input socket))
+        (close-output-port (output socket)))
+      (tcp-close socket))
+  (right none))
+
+(define (clientSocket.impl.v3 host port)
+  (with-handlers
+      [[exn:fail:network? (lambda (e) (exception "IOFailure" (exn->string e) '()))]
+       [exn:fail:contract? (lambda (e) (exception "InvalidArguments" (exn->string e) '()))]
+       [(lambda _ #t) (lambda (e) (exception "MiscFailure" "Unknown exception" e))] ]
+
+    (let-values ([(input output) (tcp-connect host (string->number port))])
+      (right (list input output)))))
+
+(define (socketSend.impl.v3 socket data)
+  (if (not (pair? socket))
+      (exception "InvalidArguments" "Cannot send on a server socket")
+      (begin
+        (write-bytes data (output socket))
+        (flush-output (output socket))
+        (right none))))
+
+(define (socketReceive.impl.v3 socket amt)
+  (if (not (pair? socket))
+      (exception "InvalidArguments" "Cannot receive on a server socket")
+      (begin
+        (let ([buffer (make-bytes amt)])
+          (read-bytes-avail! buffer (input socket))
+          (right buffer)))))
+
+; A "connected" socket is represented as a list of (list input-port output-port),
+; while a "listening" socket is just the tcp-listener itself.
+(define (socketPort.impl.v3 socket)
+  (let-values ([(_ local-port __ ___) (tcp-addresses (if (pair? socket) (input socket) socket) #t)])
+    (right local-port)))
+
+(define serverSocket.impl.v3
+  (lambda args
+    (let-values ([(hostname port)
+                  (match args
+                    [(list _ port) (values #f port)]
+                    [(list _ hostname port) (values hostname port)])])
+
+      (with-handlers
+          [[exn:fail:network? (lambda (e) (exception "IOFailure" (exn->string e) '()))]
+           [exn:fail:contract? (lambda (e) (exception "InvalidArguments" (exn->string e) '()))]
+           [(lambda _ #t) (lambda (e) (exception "MiscFailure" "Unknown exception" e))] ]
+        (let ([listener (tcp-listen (string->number port) 4 #f (if (equal? 0 hostname) #f hostname))])
+          (right listener))))))
+
+; NOTE: This is a no-op because racket's public TCP stack doesn't have separate operations for
+; "bind" vs "listen". We've decided to have `serverSocket` do the "bind & listen", and have
+; this do nothing.
+; If we want ~a little better parity with the haskell implementation, we might set a flag or
+; something on the listener, and error if you try to `accept` on a server socket that you haven't
+; called `listen` on yet.
+(define (listen.impl.v3 _listener)
+  (right none))
+
+(define (socketAccept.impl.v3 listener)
+  (if (pair? listener)
+      (exception "InvalidArguments" "Cannot accept on a non-server socket")
+      (begin
+        (let-values ([(input output) (tcp-accept listener)])
+          (right (list input output))))))

stack.yaml

@@ -10,14 +10,6 @@ build:
   interleaved-output: false
 
 packages:
-- yaks/easytest
-- parser-typechecker
-- unison-core
-- unison-cli
-- unison-hashing-v2
-- unison-share-api
-- unison-share-projects-api
-- unison-syntax
 - codebase2/codebase
 - codebase2/codebase-sqlite
 - codebase2/codebase-sqlite-hashing-v2
@@ -25,20 +17,29 @@ packages:
 - codebase2/core
 - codebase2/util-serialization
 - codebase2/util-term
-- lib/network-uri-orphans-sqlite
+- lib/orphans/network-uri-orphans-sqlite
+- lib/orphans/unison-core-orphans-sqlite
+- lib/orphans/unison-hash-orphans-aeson
+- lib/orphans/unison-hash-orphans-sqlite
+- lib/orphans/uuid-orphans-sqlite
 - lib/unison-hash
-- lib/unison-hash-orphans-aeson
-- lib/unison-hash-orphans-sqlite
 - lib/unison-hashing
 - lib/unison-prelude
+- lib/unison-pretty-printer
 - lib/unison-sqlite
 - lib/unison-util-base32hex
 - lib/unison-util-bytes
 - lib/unison-util-cache
 - lib/unison-util-relation
 - lib/unison-util-rope
-- lib/unison-pretty-printer
-- lib/uuid-orphans-sqlite
+- parser-typechecker
+- unison-cli
+- unison-core
+- unison-hashing-v2
+- unison-share-api
+- unison-share-projects-api
+- unison-syntax
+- yaks/easytest
 
 #compiler-check: match-exact
 resolver: lts-18.28

unison-cli/src/Unison/Cli/ProjectUtils.hs

@@ -4,9 +4,17 @@ module Unison.Cli.ProjectUtils
     projectPath,
     projectBranchPath,
 
+    -- * Name resolution
+    resolveNames,
+    resolveNamesToIds,
+
     -- ** Path prisms
     projectBranchPathPrism,
 
+    -- ** Project/Branch names
+    expectResolveRemoteProjectName,
+    expectResolveRemoteProjectBranchName,
+
     -- ** Temp
     loggeth,
   )
@@ -15,15 +23,21 @@ where
 import Control.Lens
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
+import Data.These (These (..))
 import Data.UUID (UUID)
 import qualified Data.UUID as UUID
 import U.Codebase.Sqlite.DbId
+import qualified U.Codebase.Sqlite.Queries as Queries
 import Unison.Cli.Monad (Cli)
+import qualified Unison.Cli.Monad as Cli
 import qualified Unison.Cli.MonadUtils as Cli
+import qualified Unison.Cli.Share.Projects as Share
+import Unison.Codebase.Editor.Output (Output (LocalProjectBranchDoesntExist))
 import qualified Unison.Codebase.Path as Path
 import Unison.NameSegment (NameSegment (..))
 import Unison.Prelude
-import Unison.Project (ProjectAndBranch (..))
+import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
+import Witch (unsafeFrom)
 
 -- | Get the current project+branch that a user is on.
 --
@@ -36,6 +50,71 @@ getCurrentProjectBranch = do
   path <- Cli.getCurrentPath
   pure (preview projectBranchPathPrism path)
 
+-- Resolve a "these names" to a "both names", using the following defaults if a name is missing:
+--
+--   * The project at the current path
+--   * The branch named "main"
+resolveNames :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch ProjectName ProjectBranchName)
+resolveNames = \case
+  This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main"))
+  That branchName -> do
+    ProjectAndBranch projectId _branchId <-
+      getCurrentProjectBranch & onNothingM do
+        loggeth ["not on a project branch"]
+        Cli.returnEarlyWithoutOutput
+    Cli.runTransaction do
+      project <- Queries.expectProject projectId
+      pure (ProjectAndBranch (project ^. #name) branchName)
+  These projectName branchName -> pure (ProjectAndBranch projectName branchName)
+
+expectResolveRemoteProjectName :: ProjectName -> Cli Share.RemoteProject
+expectResolveRemoteProjectName remoteProjectName = do
+  Share.getProjectByName remoteProjectName & onNothingM do
+    loggeth ["remote project doesn't exist"]
+    Cli.returnEarlyWithoutOutput
+
+expectResolveRemoteProjectBranchName :: RemoteProjectId -> ProjectBranchName -> Cli Share.RemoteProjectBranch
+expectResolveRemoteProjectBranchName remoteProjectId branchName = do
+  resolveRemoteProjectBranchName remoteProjectId branchName >>= \case
+    Nothing -> do
+      loggeth ["branch doesn't exist: ", tShow branchName]
+      Cli.returnEarlyWithoutOutput
+    Just x -> pure x
+
+resolveRemoteProjectBranchName :: RemoteProjectId -> ProjectBranchName -> Cli (Maybe Share.RemoteProjectBranch)
+resolveRemoteProjectBranchName remoteProjectId remoteProjectBranchName = do
+  Share.getProjectBranchByName (ProjectAndBranch remoteProjectId remoteProjectBranchName) >>= \case
+    Share.GetProjectBranchResponseBranchNotFound -> pure Nothing
+    Share.GetProjectBranchResponseProjectNotFound -> do
+      -- todo: mark remote project as deleted
+      pure Nothing
+    Share.GetProjectBranchResponseSuccess remoteBranch -> pure (Just remoteBranch)
+
+-- Like 'resolveNames', but resolves to project and branch ids.
+resolveNamesToIds :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch ProjectId ProjectBranchId)
+resolveNamesToIds = \case
+  This projectName -> resolveNamesToIds (These projectName (unsafeFrom @Text "main"))
+  That branchName -> do
+    ProjectAndBranch projectId _branchId <-
+      getCurrentProjectBranch & onNothingM do
+        loggeth ["not on a project branch yo"]
+        Cli.returnEarlyWithoutOutput
+    branch <-
+      Cli.runTransaction (Queries.loadProjectBranchByName projectId branchName) & onNothingM do
+        project <- Cli.runTransaction (Queries.expectProject projectId)
+        Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
+    pure (ProjectAndBranch projectId (branch ^. #branchId))
+  These projectName branchName -> do
+    maybeProjectAndBranch <-
+      Cli.runTransaction do
+        runMaybeT do
+          project <- MaybeT (Queries.loadProjectByName projectName)
+          let projectId = project ^. #projectId
+          branch <- MaybeT (Queries.loadProjectBranchByName projectId branchName)
+          pure (ProjectAndBranch projectId (branch ^. #branchId))
+    maybeProjectAndBranch & onNothing do
+      Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
+
 -- | Get the path that a project is stored at. Users aren't supposed to go here.
 --
 -- >>> projectPath "ABCD"

unison-cli/src/Unison/Cli/Share/Projects.hs

@@ -2,14 +2,24 @@
 {-# LANGUAGE TypeOperators #-}
 
 -- | This module contains Share API calls related to projects, wrapped in the Cli monad.
+--
+-- Here, we also validate inputs from Share that the API itself does not. For example, in the API,
+-- a project name is just a Text. But because our client requires a richer structure for project names, we try parsing
+-- them into a ProjectName, and fail right away if parsing fails.
 module Unison.Cli.Share.Projects
-  ( -- * API functions
+  ( -- * API types
+    RemoteProject (..),
+    RemoteProjectBranch (..),
+
+    -- * API functions
     getProjectById,
     getProjectByName,
     createProject,
+    GetProjectBranchResponse (..),
     getProjectBranchById,
     getProjectBranchByName,
     createProjectBranch,
+    SetProjectBranchHeadResponse (..),
     setProjectBranchHead,
 
     -- * Temporary special hard-coded base url
@@ -30,41 +40,63 @@ import qualified U.Codebase.Sqlite.Queries as Queries
 import qualified Unison.Auth.HTTPClient as Auth
 import Unison.Cli.Monad (Cli)
 import qualified Unison.Cli.Monad as Cli
+import qualified Unison.Codebase.Editor.Output as Output
+import Unison.Hash32 (Hash32)
 import Unison.Prelude
 import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
-import Unison.Share.API.Projects
+import qualified Unison.Share.API.Hash as Share.API
+import qualified Unison.Share.API.Projects as Share.API
 import Unison.Share.Codeserver (defaultCodeserver)
 import Unison.Share.Types (codeserverBaseURL)
 
+-- | A remote project.
+data RemoteProject = RemoteProject
+  { projectId :: RemoteProjectId,
+    projectName :: ProjectName
+  }
+  deriving stock (Eq, Generic, Show)
+
+-- | A remote project branch.
+data RemoteProjectBranch = RemoteProjectBranch
+  { projectId :: RemoteProjectId,
+    projectName :: ProjectName,
+    branchId :: RemoteProjectBranchId,
+    branchName :: ProjectBranchName,
+    branchHead :: Share.API.HashJWT
+  }
+  deriving stock (Eq, Show, Generic)
+
 -- | Get a project by id.
 --
 -- On success, update the `remote_project` table.
-getProjectById :: RemoteProjectId -> Cli GetProjectResponse
+getProjectById :: RemoteProjectId -> Cli (Maybe RemoteProject)
 getProjectById (RemoteProjectId projectId) = do
   response <- servantClientToCli (getProject0 (Just projectId) Nothing)
   onGetProjectResponse response
-  pure response
 
 -- | Get a project by name.
 --
 -- On success, update the `remote_project` table.
-getProjectByName :: ProjectName -> Cli GetProjectResponse
+getProjectByName :: ProjectName -> Cli (Maybe RemoteProject)
 getProjectByName projectName = do
   response <- servantClientToCli (getProject0 Nothing (Just (into @Text projectName)))
   onGetProjectResponse response
-  pure response
 
 -- | Create a new project.
 --
 -- On success, update the `remote_project` table.
-createProject :: CreateProjectRequest -> Cli CreateProjectResponse
-createProject request = do
-  response <- servantClientToCli (createProject0 request)
-  case response of
-    CreateProjectResponseNotFound {} -> pure ()
-    CreateProjectResponseUnauthorized {} -> pure ()
-    CreateProjectResponseSuccess project -> onProject project
-  pure response
+createProject :: ProjectName -> Cli (Maybe RemoteProject)
+createProject projectName = do
+  let request = Share.API.CreateProjectRequest {projectName = into @Text projectName}
+  servantClientToCli (createProject0 request) >>= \case
+    Share.API.CreateProjectResponseNotFound {} -> pure Nothing
+    Share.API.CreateProjectResponseUnauthorized x -> unauthorized x
+    Share.API.CreateProjectResponseSuccess project -> Just <$> onProject project
+
+data GetProjectBranchResponse
+  = GetProjectBranchResponseBranchNotFound
+  | GetProjectBranchResponseProjectNotFound
+  | GetProjectBranchResponseSuccess !RemoteProjectBranch
 
 -- | Get a project branch by id.
 --
@@ -73,7 +105,6 @@ getProjectBranchById :: ProjectAndBranch RemoteProjectId RemoteProjectBranchId -
 getProjectBranchById (ProjectAndBranch (RemoteProjectId projectId) (RemoteProjectBranchId branchId)) = do
   response <- servantClientToCli (getProjectBranch0 projectId (Just branchId) Nothing)
   onGetProjectBranchResponse response
-  pure response
 
 -- | Get a project branch by name.
 --
@@ -82,58 +113,97 @@ getProjectBranchByName :: ProjectAndBranch RemoteProjectId ProjectBranchName ->
 getProjectBranchByName (ProjectAndBranch (RemoteProjectId projectId) branchName) = do
   response <- servantClientToCli (getProjectBranch0 projectId Nothing (Just (into @Text branchName)))
   onGetProjectBranchResponse response
-  pure response
 
 -- | Create a new project branch.
 --
 -- On success, update the `remote_project_branch` table.
-createProjectBranch :: CreateProjectBranchRequest -> Cli CreateProjectBranchResponse
-createProjectBranch request = do
-  response <- servantClientToCli (createProjectBranch0 request)
-  case response of
-    CreateProjectBranchResponseMissingCausalHash {} -> pure ()
-    CreateProjectBranchResponseNotFound {} -> pure ()
-    CreateProjectBranchResponseUnauthorized {} -> pure ()
-    CreateProjectBranchResponseSuccess branch -> onProjectBranch branch
-  pure response
+createProjectBranch :: Share.API.CreateProjectBranchRequest -> Cli (Maybe RemoteProjectBranch)
+createProjectBranch request =
+  servantClientToCli (createProjectBranch0 request) >>= \case
+    Share.API.CreateProjectBranchResponseMissingCausalHash hash -> bugRemoteMissingCausalHash hash
+    Share.API.CreateProjectBranchResponseNotFound {} -> pure Nothing
+    Share.API.CreateProjectBranchResponseUnauthorized x -> unauthorized x
+    Share.API.CreateProjectBranchResponseSuccess branch -> Just <$> onProjectBranch branch
+
+data SetProjectBranchHeadResponse
+  = SetProjectBranchHeadResponseNotFound
+  | -- | (expected, actual)
+    SetProjectBranchHeadResponseExpectedCausalHashMismatch !Hash32 !Hash32
+  | SetProjectBranchHeadResponseSuccess
+  deriving stock (Eq, Show, Generic)
 
 -- | Set a project branch head (can be a fast-forward or force-push).
-setProjectBranchHead :: SetProjectBranchHeadRequest -> Cli SetProjectBranchHeadResponse
+setProjectBranchHead :: Share.API.SetProjectBranchHeadRequest -> Cli SetProjectBranchHeadResponse
 setProjectBranchHead request =
-  servantClientToCli (setProjectBranchHead0 request)
+  servantClientToCli (setProjectBranchHead0 request) >>= \case
+    Share.API.SetProjectBranchHeadResponseUnauthorized x -> unauthorized x
+    Share.API.SetProjectBranchHeadResponseNotFound _ -> pure SetProjectBranchHeadResponseNotFound
+    Share.API.SetProjectBranchHeadResponseMissingCausalHash hash -> bugRemoteMissingCausalHash hash
+    Share.API.SetProjectBranchHeadResponseExpectedCausalHashMismatch expected actual ->
+      pure (SetProjectBranchHeadResponseExpectedCausalHashMismatch expected actual)
+    Share.API.SetProjectBranchHeadResponseSuccess -> pure SetProjectBranchHeadResponseSuccess
 
 ------------------------------------------------------------------------------------------------------------------------
 -- Database manipulation callbacks
 
-onGetProjectResponse :: GetProjectResponse -> Cli ()
+onGetProjectResponse :: Share.API.GetProjectResponse -> Cli (Maybe RemoteProject)
 onGetProjectResponse = \case
-  GetProjectResponseNotFound {} -> pure ()
-  GetProjectResponseUnauthorized {} -> pure ()
-  GetProjectResponseSuccess project -> onProject project
+  Share.API.GetProjectResponseNotFound {} -> pure Nothing
+  Share.API.GetProjectResponseUnauthorized x -> unauthorized x
+  Share.API.GetProjectResponseSuccess project -> Just <$> onProject project
 
-onGetProjectBranchResponse :: GetProjectBranchResponse -> Cli ()
+onGetProjectBranchResponse :: Share.API.GetProjectBranchResponse -> Cli GetProjectBranchResponse
 onGetProjectBranchResponse = \case
-  GetProjectBranchResponseBranchNotFound {} -> pure ()
-  GetProjectBranchResponseProjectNotFound {} -> pure ()
-  GetProjectBranchResponseUnauthorized {} -> pure ()
-  GetProjectBranchResponseSuccess branch -> onProjectBranch branch
+  Share.API.GetProjectBranchResponseBranchNotFound {} -> pure GetProjectBranchResponseBranchNotFound
+  Share.API.GetProjectBranchResponseProjectNotFound {} -> pure GetProjectBranchResponseProjectNotFound
+  Share.API.GetProjectBranchResponseUnauthorized x -> unauthorized x
+  Share.API.GetProjectBranchResponseSuccess branch -> GetProjectBranchResponseSuccess <$> onProjectBranch branch
 
-onProject :: Project -> Cli ()
-onProject project =
-  Cli.runTransaction do
-    Queries.ensureRemoteProject
-      (RemoteProjectId (project ^. #projectId))
-      hardCodedUri
-      (project ^. #projectName)
+onProject :: Share.API.Project -> Cli RemoteProject
+onProject project = do
+  let projectId = RemoteProjectId (project ^. #projectId)
+  projectName <- validateProjectName (project ^. #projectName)
+  Cli.runTransaction (Queries.ensureRemoteProject projectId hardCodedUri projectName)
+  pure RemoteProject {projectId, projectName}
 
-onProjectBranch :: ProjectBranch -> Cli ()
-onProjectBranch branch =
+onProjectBranch :: Share.API.ProjectBranch -> Cli RemoteProjectBranch
+onProjectBranch branch = do
+  let projectId = RemoteProjectId (branch ^. #projectId)
+  let branchId = RemoteProjectBranchId (branch ^. #branchId)
+  projectName <- validateProjectName (branch ^. #projectName)
+  branchName <- validateBranchName (branch ^. #branchName)
   Cli.runTransaction do
     Queries.ensureRemoteProjectBranch
-      (RemoteProjectId (branch ^. #projectId))
+      projectId
       hardCodedUri
-      (RemoteProjectBranchId (branch ^. #branchId))
-      (branch ^. #branchName)
+      branchId
+      branchName
+  pure
+    RemoteProjectBranch
+      { projectId,
+        projectName,
+        branchId,
+        branchName,
+        branchHead = branch ^. #branchHead
+      }
+
+validateProjectName :: Text -> Cli ProjectName
+validateProjectName projectName =
+  tryInto @ProjectName projectName & onLeft \err -> do
+    Cli.returnEarlyWithoutOutput
+
+validateBranchName :: Text -> Cli ProjectBranchName
+validateBranchName branchName =
+  tryInto @ProjectBranchName branchName & onLeft \err -> do
+    Cli.returnEarlyWithoutOutput
+
+unauthorized :: Share.API.Unauthorized -> Cli void
+unauthorized (Share.API.Unauthorized message) =
+  Cli.returnEarly (Output.Unauthorized message)
+
+bugRemoteMissingCausalHash :: Hash32 -> a
+bugRemoteMissingCausalHash hash =
+  error (reportBug "E796475" ("Create remote branch: causal hash missing: " ++ show hash))
 
 ------------------------------------------------------------------------------------------------------------------------
 -- Low-level servant client generation and wrapping
@@ -164,15 +234,15 @@ servantClientToCli action = do
     liftIO (putStrLn "FIXME: ^ make this prettier")
     Cli.returnEarlyWithoutOutput
 
-getProject0 :: Maybe Text -> Maybe Text -> ClientM GetProjectResponse
-createProject0 :: CreateProjectRequest -> ClientM CreateProjectResponse
-getProjectBranch0 :: Text -> Maybe Text -> Maybe Text -> ClientM GetProjectBranchResponse
-createProjectBranch0 :: CreateProjectBranchRequest -> ClientM CreateProjectBranchResponse
-setProjectBranchHead0 :: SetProjectBranchHeadRequest -> ClientM SetProjectBranchHeadResponse
+getProject0 :: Maybe Text -> Maybe Text -> ClientM Share.API.GetProjectResponse
+createProject0 :: Share.API.CreateProjectRequest -> ClientM Share.API.CreateProjectResponse
+getProjectBranch0 :: Text -> Maybe Text -> Maybe Text -> ClientM Share.API.GetProjectBranchResponse
+createProjectBranch0 :: Share.API.CreateProjectBranchRequest -> ClientM Share.API.CreateProjectBranchResponse
+setProjectBranchHead0 :: Share.API.SetProjectBranchHeadRequest -> ClientM Share.API.SetProjectBranchHeadResponse
 ( getProject0
     :<|> createProject0
     :<|> getProjectBranch0
     :<|> createProjectBranch0
     :<|> setProjectBranchHead0
   ) =
-    client (Proxy :: Proxy ("ucm" :> "v1" :> "projects" :> ProjectsAPI))
+    client (Proxy :: Proxy ("ucm" :> "v1" :> "projects" :> Share.API.ProjectsAPI))

unison-cli/src/Unison/Codebase/Editor/HandleInput.hs

@@ -61,7 +61,7 @@ import qualified Unison.Cli.MonadUtils as Cli
 import Unison.Cli.NamesUtils (basicParseNames, displayNames, findHistoricalHQs, getBasicPrettyPrintNames, makeHistoricalParsingNames, makePrintNamesFromLabeled', makeShadowedPrintNamesFromHQ)
 import Unison.Cli.PrettyPrintUtils (currentPrettyPrintEnvDecl, prettyPrintEnvDecl)
 import Unison.Cli.TypeCheck (typecheck, typecheckTerm)
-import Unison.Codebase (Codebase, Preprocessing (..))
+import Unison.Codebase (Codebase)
 import qualified Unison.Codebase as Codebase
 import Unison.Codebase.Branch (Branch (..), Branch0 (..))
 import qualified Unison.Codebase.Branch as Branch
@@ -72,8 +72,9 @@ import qualified Unison.Codebase.Causal as Causal
 import Unison.Codebase.Editor.AuthorInfo (AuthorInfo (..))
 import qualified Unison.Codebase.Editor.AuthorInfo as AuthorInfo
 import Unison.Codebase.Editor.DisplayObject
-import qualified Unison.Codebase.Editor.Git as Git
 import Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin)
+import Unison.Codebase.Editor.HandleInput.CreatePullRequest (handleCreatePullRequest)
+import Unison.Codebase.Editor.HandleInput.LoadPullRequest (handleLoadPullRequest)
 import Unison.Codebase.Editor.HandleInput.MetadataUtils (addDefaultMetadata, manageLinks)
 import Unison.Codebase.Editor.HandleInput.MoveBranch (doMoveBranch)
 import qualified Unison.Codebase.Editor.HandleInput.NamespaceDependencies as NamespaceDependencies
@@ -81,7 +82,7 @@ import Unison.Codebase.Editor.HandleInput.NamespaceDiffUtils (diffHelper)
 import Unison.Codebase.Editor.HandleInput.ProjectClone (projectClone)
 import Unison.Codebase.Editor.HandleInput.ProjectCreate (projectCreate)
 import Unison.Codebase.Editor.HandleInput.ProjectSwitch (projectSwitch)
-import Unison.Codebase.Editor.HandleInput.Pull (doPullRemoteBranch, importRemoteShareBranch, loadPropagateDiffDefaultPatch, mergeBranchAndPropagateDefaultPatch, propagatePatch)
+import Unison.Codebase.Editor.HandleInput.Pull (doPullRemoteBranch, mergeBranchAndPropagateDefaultPatch, propagatePatch)
 import Unison.Codebase.Editor.HandleInput.Push (handleGist, handlePushRemoteBranch)
 import Unison.Codebase.Editor.HandleInput.TermResolution
   ( resolveCon,
@@ -435,38 +436,8 @@ loop e = do
               Cli.respondNumbered (ShowDiffNamespace absBefore absAfter ppe diff)
             CreatePullRequestI baseRepo headRepo -> handleCreatePullRequest baseRepo headRepo
             LoadPullRequestI baseRepo headRepo dest0 -> do
-              Cli.assertNoBranchAtPath' dest0
-              Cli.Env {codebase} <- ask
               description <- inputDescription input
-              destAbs <- Cli.resolvePath' dest0
-              let getBranch = \case
-                    ReadRemoteNamespaceGit repo ->
-                      Cli.ioE (Codebase.importRemoteBranch codebase repo SyncMode.ShortCircuit Unmodified) \err ->
-                        Cli.returnEarly (Output.GitError err)
-                    ReadRemoteNamespaceShare repo -> importRemoteShareBranch repo
-              baseb <- getBranch baseRepo
-              headb <- getBranch headRepo
-              mergedb <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge baseb headb)
-              squashedb <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.SquashMerge headb baseb)
-              Cli.updateAt description destAbs $ Branch.step \destBranch0 ->
-                destBranch0
-                  & Branch.children
-                    %~ ( \childMap ->
-                           childMap
-                             & at "base" ?~ baseb
-                             & at "head" ?~ headb
-                             & at "merged" ?~ mergedb
-                             & at "squashed" ?~ squashedb
-                       )
-              let base = snoc dest0 "base"
-                  head = snoc dest0 "head"
-                  merged = snoc dest0 "merged"
-                  squashed = snoc dest0 "squashed"
-              Cli.respond $ LoadPullRequest baseRepo headRepo base head merged squashed
-              loadPropagateDiffDefaultPatch
-                description
-                (Just merged)
-                (snoc destAbs "merged")
+              handleLoadPullRequest description baseRepo headRepo dest0
             MoveBranchI src' dest' -> do
               hasConfirmed <- confirmedCommand input
               description <- inputDescription input
@@ -1149,7 +1120,7 @@ loop e = do
             CompileSchemeI output main -> doCompileScheme output main
             ExecuteSchemeI main args -> doRunAsScheme main args
             GenSchemeLibsI -> doGenerateSchemeBoot True Nothing
-            FetchSchemeCompilerI -> doFetchCompiler
+            FetchSchemeCompilerI name -> doFetchCompiler name
             IOTestI main -> handleIOTest main
             -- UpdateBuiltinsI -> do
             --   stepAt updateBuiltins
@@ -1202,9 +1173,9 @@ loop e = do
               patch <- Cli.getPatchAt (fromMaybe Cli.defaultPatchPath maybePath)
               ppe <- suffixifiedPPE =<< makePrintNamesFromLabeled' (Patch.labeledDependencies patch)
               Cli.respondNumbered $ ListEdits patch ppe
-            PullRemoteBranchI mRepo path sMode pMode verbosity ->
+            PullRemoteBranchI sourceTarget sMode pMode verbosity ->
               inputDescription input
-                >>= doPullRemoteBranch mRepo path sMode pMode verbosity
+                >>= doPullRemoteBranch sourceTarget sMode pMode verbosity
             PushRemoteBranchI pushRemoteBranchInput -> handlePushRemoteBranch pushRemoteBranchInput
             ListDependentsI hq -> handleDependents hq
             ListDependenciesI hq -> do
@@ -1498,9 +1469,9 @@ inputDescription input =
           <> Text.unwords (fmap Text.pack args)
     CompileSchemeI fi nm -> pure ("compile.native " <> HQ.toText nm <> " " <> Text.pack fi)
     GenSchemeLibsI -> pure "compile.native.genlibs"
-    FetchSchemeCompilerI -> pure "compile.native.fetch"
-    PullRemoteBranchI orepo dest0 _syncMode pullMode _ -> do
-      dest <- p' dest0
+    FetchSchemeCompilerI name -> pure ("compile.native.fetch" <> Text.pack name)
+    PullRemoteBranchI sourceTarget _syncMode pullMode _ -> do
+      dest <- wundefined -- p' dest0
       let command =
             Text.pack . InputPattern.patternName $
               case pullMode of
@@ -1512,8 +1483,8 @@ inputDescription input =
           -- todo: show the actual config-loaded namespace
           <> maybe
             "(remote namespace from .unisonConfig)"
-            printNamespace
-            orepo
+            wundefined -- (printNamespace absurd)
+            wundefined -- orepo
           <> " "
           <> dest
     CreateAuthorI (NameSegment id) name -> pure ("create.author " <> id <> " " <> name)
@@ -1521,9 +1492,9 @@ inputDescription input =
       dest <- p' dest0
       pure $
         "pr.load "
-          <> printNamespace base
+          <> printNamespace (into @Text) base
           <> " "
-          <> printNamespace head
+          <> printNamespace (into @Text) head
           <> " "
           <> dest
     RemoveTermReplacementI src p0 -> do
@@ -1608,23 +1579,6 @@ inputDescription input =
     hqs (p, hq) = hqs' (Path' . Right . Path.Relative $ p, hq)
     ps' = p' . Path.unsplit'
 
-handleCreatePullRequest :: ReadRemoteNamespace -> ReadRemoteNamespace -> Cli ()
-handleCreatePullRequest baseRepo0 headRepo0 = do
-  Cli.Env {codebase} <- ask
-
-  let withBranch :: ReadRemoteNamespace -> (forall x. (Branch IO -> Cli x) -> Cli x)
-      withBranch rrn k = case rrn of
-        ReadRemoteNamespaceGit repo -> do
-          Cli.withE (Codebase.viewRemoteBranch codebase repo Git.RequireExistingBranch) \case
-            Left err -> Cli.returnEarly (Output.GitError err)
-            Right x -> k x
-        ReadRemoteNamespaceShare repo -> k =<< importRemoteShareBranch repo
-
-  (ppe, diff) <- withBranch baseRepo0 \baseBranch -> withBranch headRepo0 \headBranch -> do
-    merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge baseBranch headBranch)
-    diffHelper (Branch.head baseBranch) (Branch.head merged)
-  Cli.respondNumbered (ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff)
-
 handleFindI ::
   Bool ->
   FindScope ->
@@ -2303,12 +2257,11 @@ compilerPath = Path.Path' {Path.unPath' = Left abs}
     rootPath = Path.Path {Path.toSeq = Seq.fromList segs}
     abs = Path.Absolute {Path.unabsolute = rootPath}
 
-doFetchCompiler :: Cli ()
-doFetchCompiler =
+doFetchCompiler :: String -> Cli ()
+doFetchCompiler username =
   inputDescription pullInput
     >>= doPullRemoteBranch
-      repo
-      compilerPath
+      sourceTarget
       SyncMode.Complete
       Input.PullWithoutHistory
       Verbosity.Silent
@@ -2317,16 +2270,15 @@ doFetchCompiler =
     ns =
       ReadShareRemoteNamespace
         { server = RemoteRepo.DefaultCodeserver,
-          repo = ShareUserHandle "unison",
+          repo = ShareUserHandle (Text.pack username),
           path =
             Path.fromList $ NameSegment <$> ["public", "internal", "trunk"]
         }
-    repo = Just $ ReadRemoteNamespaceShare ns
+    sourceTarget = PullSourceTarget2 (ReadRemoteNamespaceShare ns) (PullTargetLooseCode compilerPath)
 
     pullInput =
       PullRemoteBranchI
-        repo
-        compilerPath
+        sourceTarget
         SyncMode.Complete
         Input.PullWithoutHistory
         Verbosity.Silent
@@ -2334,7 +2286,7 @@ doFetchCompiler =
 ensureCompilerExists :: Cli ()
 ensureCompilerExists =
   Cli.branchExistsAtPath' compilerPath
-    >>= flip unless doFetchCompiler
+    >>= flip unless (doFetchCompiler "unison")
 
 getCacheDir :: Cli String
 getCacheDir = liftIO $ getXdgDirectory XdgCache "unisonlanguage"

unison-cli/src/Unison/Codebase/Editor/HandleInput/CreatePullRequest.hs

@@ -0,0 +1,42 @@
+module Unison.Codebase.Editor.HandleInput.CreatePullRequest
+  ( handleCreatePullRequest,
+  )
+where
+
+import Control.Monad.Reader (ask)
+import Data.These (These)
+import Unison.Cli.Monad (Cli)
+import qualified Unison.Cli.Monad as Cli
+import qualified Unison.Codebase as Codebase
+import Unison.Codebase.Branch (Branch (..))
+import qualified Unison.Codebase.Branch as Branch
+import qualified Unison.Codebase.Branch.Merge as Branch
+import qualified Unison.Codebase.Editor.Git as Git
+import Unison.Codebase.Editor.HandleInput.NamespaceDiffUtils (diffHelper)
+import Unison.Codebase.Editor.HandleInput.Pull (importRemoteShareBranch)
+import Unison.Codebase.Editor.Output
+import qualified Unison.Codebase.Editor.Output as Output
+import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..))
+import Unison.Prelude
+import Unison.Project (ProjectBranchName, ProjectName)
+
+handleCreatePullRequest ::
+  ReadRemoteNamespace (These ProjectName ProjectBranchName) ->
+  ReadRemoteNamespace (These ProjectName ProjectBranchName) ->
+  Cli ()
+handleCreatePullRequest baseRepo0 headRepo0 = do
+  Cli.Env {codebase} <- ask
+
+  let withBranch :: ReadRemoteNamespace Void -> (forall x. (Branch IO -> Cli x) -> Cli x)
+      withBranch rrn k = case rrn of
+        ReadRemoteNamespaceGit repo -> do
+          Cli.withE (Codebase.viewRemoteBranch codebase repo Git.RequireExistingBranch) \case
+            Left err -> Cli.returnEarly (Output.GitError err)
+            Right x -> k x
+        ReadRemoteNamespaceShare repo -> k =<< importRemoteShareBranch repo
+        ReadRemoteProjectBranch _ -> wundefined
+
+  (ppe, diff) <- withBranch (wundefined baseRepo0) \baseBranch -> withBranch (wundefined headRepo0) \headBranch -> do
+    merged <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge baseBranch headBranch)
+    diffHelper (Branch.head baseBranch) (Branch.head merged)
+  Cli.respondNumbered (ShowDiffAfterCreatePR (wundefined baseRepo0) (wundefined headRepo0) ppe diff)

unison-cli/src/Unison/Codebase/Editor/HandleInput/LoadPullRequest.hs

@@ -0,0 +1,63 @@
+module Unison.Codebase.Editor.HandleInput.LoadPullRequest
+  ( handleLoadPullRequest,
+  )
+where
+
+import Control.Lens
+import Control.Monad.Reader (ask)
+import Data.These (These)
+import Unison.Cli.Monad (Cli)
+import qualified Unison.Cli.Monad as Cli
+import qualified Unison.Cli.MonadUtils as Cli
+import Unison.Codebase (Preprocessing (..))
+import qualified Unison.Codebase as Codebase
+import qualified Unison.Codebase.Branch as Branch
+import qualified Unison.Codebase.Branch.Merge as Branch
+import Unison.Codebase.Editor.HandleInput.Pull (importRemoteShareBranch, loadPropagateDiffDefaultPatch)
+import Unison.Codebase.Editor.Output
+import qualified Unison.Codebase.Editor.Output as Output
+import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..))
+import Unison.Codebase.Path (Path' (..))
+import qualified Unison.Codebase.SyncMode as SyncMode
+import Unison.Prelude
+import Unison.Project (ProjectBranchName, ProjectName)
+
+handleLoadPullRequest ::
+  Text ->
+  (ReadRemoteNamespace (These ProjectName ProjectBranchName)) ->
+  (ReadRemoteNamespace (These ProjectName ProjectBranchName)) ->
+  Path' ->
+  Cli ()
+handleLoadPullRequest description baseRepo headRepo dest0 = do
+  Cli.assertNoBranchAtPath' dest0
+  Cli.Env {codebase} <- ask
+  destAbs <- Cli.resolvePath' dest0
+  let getBranch = \case
+        ReadRemoteNamespaceGit repo ->
+          Cli.ioE (Codebase.importRemoteBranch codebase repo SyncMode.ShortCircuit Unmodified) \err ->
+            Cli.returnEarly (Output.GitError err)
+        ReadRemoteNamespaceShare repo -> importRemoteShareBranch repo
+        ReadRemoteProjectBranch _ -> wundefined
+  baseb <- getBranch baseRepo
+  headb <- getBranch headRepo
+  mergedb <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge baseb headb)
+  squashedb <- liftIO (Branch.merge'' (Codebase.lca codebase) Branch.SquashMerge headb baseb)
+  Cli.updateAt description destAbs $ Branch.step \destBranch0 ->
+    destBranch0
+      & Branch.children
+        %~ ( \childMap ->
+               childMap
+                 & at "base" ?~ baseb
+                 & at "head" ?~ headb
+                 & at "merged" ?~ mergedb
+                 & at "squashed" ?~ squashedb
+           )
+  let base = snoc dest0 "base"
+      head = snoc dest0 "head"
+      merged = snoc dest0 "merged"
+      squashed = snoc dest0 "squashed"
+  Cli.respond $ LoadPullRequest (wundefined baseRepo) (wundefined headRepo) base head merged squashed
+  loadPropagateDiffDefaultPatch
+    description
+    (Just merged)
+    (snoc destAbs "merged")

unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs

@@ -8,7 +8,7 @@ import Control.Lens ((^.))
 import Control.Monad.Reader (ask)
 import Data.These (These (..))
 import qualified Data.UUID.V4 as UUID
-import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..), RemoteProjectBranchId (..), RemoteProjectId (..))
+import U.Codebase.Sqlite.DbId (ProjectBranchId (..), ProjectId (..))
 import qualified U.Codebase.Sqlite.Queries as Queries
 import Unison.Cli.Monad (Cli)
 import qualified Unison.Cli.Monad as Cli
@@ -23,7 +23,6 @@ import qualified Unison.Codebase.Path as Path
 import Unison.Prelude
 import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName, projectNameUserSlug)
 import qualified Unison.Share.API.Hash as Share.API
-import qualified Unison.Share.API.Projects as Share.API
 import qualified Unison.Share.Sync as Share (downloadEntities)
 import qualified Unison.Sqlite as Sqlite
 import Unison.Sync.Common (hash32ToCausalHash)
@@ -69,29 +68,23 @@ cloneProjectAndBranch remoteProjectAndBranch = do
   -- Quick local check before hitting share to determine whether this project+branch already exists.
   let assertLocalProjectBranchDoesntExist :: Sqlite.Transaction (Either Output.Output (Maybe Queries.Project))
       assertLocalProjectBranchDoesntExist =
-        Queries.loadProjectByName (into @Text localProjectName) >>= \case
+        Queries.loadProjectByName localProjectName >>= \case
           Nothing -> pure (Right Nothing)
           Just project ->
-            Queries.projectBranchExistsByName (project ^. #projectId) (into @Text localBranchName) <&> \case
+            Queries.projectBranchExistsByName (project ^. #projectId) localBranchName <&> \case
               False -> Right (Just project)
-              True -> Left (Output.ProjectAndBranchNameAlreadyExists (ProjectAndBranch localProjectName localBranchName))
+              True ->
+                let localProject = ProjectAndBranch localProjectName localBranchName
+                 in Left (Output.ProjectAndBranchNameAlreadyExists localProject)
   void (Cli.runEitherTransaction assertLocalProjectBranchDoesntExist)
 
   -- Get the branch of the given project.
   remoteProjectBranch <- do
-    project <-
-      Share.getProjectByName remoteProjectName >>= \case
-        Share.API.GetProjectResponseNotFound _ -> remoteProjectBranchDoesntExist
-        Share.API.GetProjectResponseUnauthorized (Share.API.Unauthorized message) ->
-          Cli.returnEarly (Output.Unauthorized message)
-        Share.API.GetProjectResponseSuccess project -> pure project
-    let remoteProjectId = RemoteProjectId (project ^. #projectId)
-    Share.getProjectBranchByName (ProjectAndBranch remoteProjectId remoteBranchName) >>= \case
-      Share.API.GetProjectBranchResponseBranchNotFound _ -> remoteProjectBranchDoesntExist
-      Share.API.GetProjectBranchResponseProjectNotFound _ -> remoteProjectBranchDoesntExist
-      Share.API.GetProjectBranchResponseUnauthorized (Share.API.Unauthorized message) ->
-        Cli.returnEarly (Output.Unauthorized message)
-      Share.API.GetProjectBranchResponseSuccess projectBranch -> pure projectBranch
+    project <- Share.getProjectByName remoteProjectName & onNothingM remoteProjectBranchDoesntExist
+    Share.getProjectBranchByName (ProjectAndBranch (project ^. #projectId) remoteBranchName) >>= \case
+      Share.GetProjectBranchResponseBranchNotFound -> remoteProjectBranchDoesntExist
+      Share.GetProjectBranchResponseProjectNotFound -> remoteProjectBranchDoesntExist
+      Share.GetProjectBranchResponseSuccess projectBranch -> pure projectBranch
 
   -- Pull the remote branch's contents
   let remoteBranchHeadJwt = remoteProjectBranch ^. #branchHead
@@ -118,17 +111,17 @@ cloneProjectAndBranch remoteProjectAndBranch = do
             case maybeLocalProject of
               Nothing -> do
                 localProjectId <- Sqlite.unsafeIO (ProjectId <$> UUID.nextRandom)
-                Queries.insertProject localProjectId (into @Text localProjectName)
+                Queries.insertProject localProjectId localProjectName
                 pure localProjectId
               Just localProject -> pure (localProject ^. #projectId)
           localBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom)
-          Queries.insertProjectBranch localProjectId localBranchId (into @Text localBranchName)
+          Queries.insertProjectBranch localProjectId localBranchId localBranchName
           Queries.insertBranchRemoteMapping
             localProjectId
             localBranchId
-            (RemoteProjectId (remoteProjectBranch ^. #projectId))
+            (remoteProjectBranch ^. #projectId)
             Share.hardCodedUri
-            (RemoteProjectBranchId (remoteProjectBranch ^. #branchId))
+            (remoteProjectBranch ^. #branchId)
           pure (Right (ProjectAndBranch localProjectId localBranchId))
 
   -- Manipulate the root namespace and cd

unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs

@@ -17,6 +17,7 @@ import qualified Unison.Codebase.Editor.Output as Output
 import qualified Unison.Codebase.Path as Path
 import Unison.Prelude
 import Unison.Project (ProjectAndBranch (..), ProjectName)
+import Witch (unsafeFrom)
 
 -- | Create a new project.
 --
@@ -50,10 +51,10 @@ projectCreate name = do
   branchId <- liftIO (ProjectBranchId <$> UUID.nextRandom)
 
   Cli.runEitherTransaction do
-    Queries.projectExistsByName (into @Text name) >>= \case
+    Queries.projectExistsByName name >>= \case
       False -> do
-        Queries.insertProject projectId (into @Text name)
-        Queries.insertProjectBranch projectId branchId "main"
+        Queries.insertProject projectId name
+        Queries.insertProjectBranch projectId branchId (unsafeFrom @Text "main")
         pure (Right ())
       True -> pure (Left (Output.ProjectNameAlreadyExists name))
 

unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs

@@ -32,15 +32,13 @@ projectSwitch = \case
         Cli.returnEarlyWithoutOutput
     let projectId = projectAndBranch ^. #project
     project <- Cli.runTransaction (Queries.expectProject projectId)
-    let projectName = unsafeFrom @Text (project ^. #name)
-    switchToProjectAndBranch2 (ProjectAndBranch (projectId, projectName) branchName) (Just projectAndBranch)
+    switchToProjectAndBranch2 (ProjectAndBranch (projectId, project ^. #name) branchName) (Just projectAndBranch)
 
 -- Switch to a project+branch.
 switchToProjectAndBranch :: ProjectAndBranch ProjectName ProjectBranchName -> Cli ()
 switchToProjectAndBranch projectAndBranch = do
-  project <- do
-    let projectName = into @Text (projectAndBranch ^. #project)
-    Cli.runTransaction (Queries.loadProjectByName projectName) & onNothingM do
+  project <-
+    Cli.runTransaction (Queries.loadProjectByName (projectAndBranch ^. #project)) & onNothingM do
       loggeth ["no such project"]
       Cli.returnEarlyWithoutOutput
   let projectId = project ^. #projectId
@@ -59,11 +57,11 @@ switchToProjectAndBranch2 ::
 switchToProjectAndBranch2 (ProjectAndBranch (projectId, projectName) branchName) maybeCurrentProject = do
   (outcome, branchId) <-
     Cli.runTransaction do
-      Queries.loadProjectBranchByName projectId (into @Text branchName) >>= \case
+      Queries.loadProjectBranchByName projectId branchName >>= \case
         Just branch -> pure (SwitchedToExistingBranch, branch ^. #branchId)
         Nothing -> do
           newBranchId <- Sqlite.unsafeIO (ProjectBranchId <$> UUID.nextRandom)
-          Queries.insertProjectBranch projectId newBranchId (into @Text branchName)
+          Queries.insertProjectBranch projectId newBranchId branchName
           fromBranchId <-
             case maybeCurrentProject of
               Just (ProjectAndBranch currentProjectId currentBranchId)
@@ -73,7 +71,7 @@ switchToProjectAndBranch2 (ProjectAndBranch (projectId, projectName) branchName)
                 -- For now, we treat switching to a new branch from outside of a project as equivalent to switching to a
                 -- new branch from the branch called "main" in that project. Eventually, we should probably instead
                 -- use the default project branch
-                Queries.loadProjectBranchByName projectId "main" >>= \case
+                Queries.loadProjectBranchByName projectId (unsafeFrom @Text "main") >>= \case
                   Nothing ->
                     error $
                       reportBug "E469471" $

unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs

@@ -10,14 +10,19 @@ module Unison.Codebase.Editor.HandleInput.Pull
 where
 
 import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, readTVarIO)
-import Control.Lens
+import Control.Lens (over, snoc, (^.))
 import Control.Monad.Reader (ask)
 import qualified Data.List.NonEmpty as Nel
+import Data.These
 import qualified System.Console.Regions as Console.Regions
+import U.Codebase.Sqlite.DbId (RemoteProjectBranchId (..), RemoteProjectId (..))
+import qualified U.Codebase.Sqlite.Queries as Queries
 import Unison.Cli.Monad (Cli)
 import qualified Unison.Cli.Monad as Cli
 import qualified Unison.Cli.MonadUtils as Cli
-import Unison.Cli.UnisonConfigUtils (resolveConfiguredUrl)
+import Unison.Cli.ProjectUtils (loggeth)
+import qualified Unison.Cli.ProjectUtils as ProjectUtils
+import qualified Unison.Cli.Share.Projects as Share
 import Unison.Codebase (Preprocessing (..))
 import qualified Unison.Codebase as Codebase
 import Unison.Codebase.Branch (Branch (..))
@@ -29,59 +34,105 @@ import Unison.Codebase.Editor.Input
 import qualified Unison.Codebase.Editor.Input as Input
 import Unison.Codebase.Editor.Output
 import qualified Unison.Codebase.Editor.Output as Output
-import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull))
 import qualified Unison.Codebase.Editor.Propagate as Propagate
 import Unison.Codebase.Editor.RemoteRepo
   ( ReadRemoteNamespace (..),
     ReadShareRemoteNamespace (..),
     ShareUserHandle (..),
-    writePathToRead,
   )
 import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo
 import Unison.Codebase.Patch (Patch (..))
-import Unison.Codebase.Path (Path' (..))
 import qualified Unison.Codebase.Path as Path
 import qualified Unison.Codebase.SyncMode as SyncMode
 import qualified Unison.Codebase.Verbosity as Verbosity
 import Unison.NameSegment (NameSegment (..))
 import Unison.Prelude
+import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
 import qualified Unison.Share.Codeserver as Codeserver
 import qualified Unison.Share.Sync as Share
 import qualified Unison.Share.Sync.Types as Share
 import Unison.Share.Types (codeserverBaseURL)
+import Unison.Sqlite (Transaction)
 import qualified Unison.Sync.Types as Share
+import Witch (unsafeFrom)
 
 doPullRemoteBranch ::
-  Maybe ReadRemoteNamespace ->
-  Path' ->
+  PullSourceTarget ->
   SyncMode.SyncMode ->
   PullMode ->
   Verbosity.Verbosity ->
   Text ->
   Cli ()
-doPullRemoteBranch mayRepo path syncMode pullMode verbosity description = do
+doPullRemoteBranch sourceTarget {- mayRepo target -} syncMode pullMode verbosity description = do
   Cli.Env {codebase} <- ask
   let preprocess = case pullMode of
         Input.PullWithHistory -> Unmodified
         Input.PullWithoutHistory -> Preprocessed $ pure . Branch.discardHistory
-  ns <- maybe (writePathToRead <$> resolveConfiguredUrl Pull path) pure mayRepo
+  ns :: ReadRemoteNamespace (ProjectAndBranch (RemoteProjectId, ProjectName) Share.RemoteProjectBranch) <-
+    case sourceTarget of
+      Input.PullSourceTarget0 ->
+        ProjectUtils.getCurrentProjectBranch >>= \case
+          Nothing -> wundefined
+          Just (ProjectAndBranch projectId projectBranchId) ->
+            let loadRemoteNames :: Transaction (Maybe (RemoteProjectId, ProjectName, RemoteProjectBranchId, ProjectBranchName))
+                loadRemoteNames = runMaybeT do
+                  (remoteProjectId, mremoteBranchId) <- MaybeT (Queries.loadRemoteProjectBranch projectId projectBranchId)
+                  remoteBranchId <- MaybeT (pure mremoteBranchId)
+                  remoteProjectName <- lift $ Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri
+                  remoteProjectBranchName <- lift $ Queries.expectRemoteProjectBranchName Share.hardCodedUri remoteProjectId remoteBranchId
+                  pure (remoteProjectId, remoteProjectName, remoteBranchId, remoteProjectBranchName)
+             in Cli.runTransaction loadRemoteNames >>= \case
+                  Nothing -> do
+                    loggeth ["No default pull target for this branch"]
+                    Cli.returnEarlyWithoutOutput
+                  Just (remoteProjectId, remoteProjectName, remoteProjectBranchId, _remoteProjectBranchName) -> do
+                    branch <- expectRemoteProjectBranchById remoteProjectId remoteProjectBranchId
+                    pure (ReadRemoteProjectBranch (ProjectAndBranch (remoteProjectId, remoteProjectName) branch))
+      Input.PullSourceTarget1 source -> case source of
+        ReadRemoteProjectBranch projectAndBranchNames -> ReadRemoteProjectBranch <$> resolveRemoteNames projectAndBranchNames
+        _ -> wundefined
+      Input.PullSourceTarget2 source _target -> wundefined source
   remoteBranch <- case ns of
     ReadRemoteNamespaceGit repo ->
       Cli.ioE (Codebase.importRemoteBranch codebase repo syncMode preprocess) \err ->
         Cli.returnEarly (Output.GitError err)
     ReadRemoteNamespaceShare repo -> importRemoteShareBranch repo
+    ReadRemoteProjectBranch (ProjectAndBranch (_, remoteProjectName) branch) ->
+      let repoInfo = Share.RepoInfo (into @Text (These remoteProjectName remoteProjectBranchName))
+          causalHash = wundefined
+          causalHashJwt = wundefined
+          remoteProjectBranchName = branch ^. #branchName
+       in Cli.with withEntitiesDownloadedProgressCallback \downloadedCallback ->
+            Share.downloadEntities Share.hardCodedBaseUrl repoInfo causalHashJwt downloadedCallback >>= \case
+              Left err -> wundefined err
+              Right () -> liftIO (Codebase.expectBranchForHash codebase causalHash)
+  let nsNamesOnly :: ReadRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName)
+      nsNamesOnly =
+        over
+          #_ReadRemoteProjectBranch
+          (\(ProjectAndBranch (_, projectName) branch) -> ProjectAndBranch projectName (branch ^. #branchName))
+          ns
   when (Branch.isEmpty0 (Branch.head remoteBranch)) do
-    Cli.respond (PulledEmptyBranch ns)
-  let unchangedMsg = PullAlreadyUpToDate ns path
-  destAbs <- Cli.resolvePath' path
-  let printDiffPath = if Verbosity.isSilent verbosity then Nothing else Just path
+    Cli.respond (PulledEmptyBranch nsNamesOnly)
+  target <- wundefined
+  let unchangedMsg = PullAlreadyUpToDate nsNamesOnly target
+  destAbs <-
+    case target of
+      PullTargetLooseCode path -> Cli.resolvePath' path
+      PullTargetProject _ -> wundefined
+  let printDiffPath =
+        if Verbosity.isSilent verbosity
+          then Nothing
+          else case target of
+            PullTargetLooseCode path -> Just path
+            PullTargetProject _ -> wundefined
   case pullMode of
     Input.PullWithHistory -> do
       destBranch <- Cli.getBranch0At destAbs
       if Branch.isEmpty0 destBranch
         then do
           void $ Cli.updateAtM description destAbs (const $ pure remoteBranch)
-          Cli.respond $ MergeOverEmpty path
+          Cli.respond $ MergeOverEmpty target
         else
           mergeBranchAndPropagateDefaultPatch
             Branch.RegularMerge
@@ -98,7 +149,7 @@ doPullRemoteBranch mayRepo path syncMode pullMode verbosity description = do
           (\destBranch -> pure $ remoteBranch `Branch.consBranchSnapshot` destBranch)
       Cli.respond
         if didUpdate
-          then PullSuccessful ns path
+          then PullSuccessful nsNamesOnly target
           else unchangedMsg
 
 importRemoteShareBranch :: ReadShareRemoteNamespace -> Cli (Branch IO)
@@ -116,7 +167,7 @@ importRemoteShareBranch rrn@(ReadShareRemoteNamespace {server, repo, path}) = do
           Share.SyncError err -> Output.ShareErrorPull err
           Share.TransportError err -> Output.ShareErrorTransport err
   liftIO (Codebase.expectBranchForHash codebase causalHash)
-  
+
 -- Provide the given action a callback that display to the terminal.
 withEntitiesDownloadedProgressCallback :: ((Int -> IO ()) -> IO a) -> IO a
 withEntitiesDownloadedProgressCallback action = do
@@ -191,3 +242,54 @@ propagatePatch inputDescription patch scopePath = do
     Cli.stepAt'
       (inputDescription <> " (applying patch)")
       (Path.unabsolute scopePath, Propagate.propagateAndApply patch)
+
+resolveRemoteNames ::
+  These ProjectName ProjectBranchName ->
+  Cli (ProjectAndBranch (RemoteProjectId, ProjectName) Share.RemoteProjectBranch)
+resolveRemoteNames = \case
+  This projectName -> do
+    remoteProject <- ProjectUtils.expectResolveRemoteProjectName projectName
+    let remoteProjectId = remoteProject ^. #projectId
+    let remoteBranchName = unsafeFrom @Text "main"
+    remoteBranch <- expectRemoteProjectBranchByName remoteProjectId remoteBranchName
+    pure (ProjectAndBranch (remoteProjectId, projectName) remoteBranch)
+  That branchName -> do
+    ProjectAndBranch projectId branchId <-
+      ProjectUtils.getCurrentProjectBranch & onNothingM do
+        loggeth ["not on a project branch"]
+        Cli.returnEarlyWithoutOutput
+    Cli.runTransaction (Queries.loadRemoteProjectBranch projectId branchId) >>= \case
+      Just (remoteProjectId, _maybeProjectBranchId) -> do
+        projectName <- Cli.runTransaction (Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri)
+        remoteBranch <- expectRemoteProjectBranchByName remoteProjectId branchName
+        pure (ProjectAndBranch (remoteProjectId, projectName) remoteBranch)
+      Nothing -> do
+        loggeth ["no remote associated with this project"]
+        Cli.returnEarlyWithoutOutput
+  These projectName branchName -> do
+    remoteProject <- ProjectUtils.expectResolveRemoteProjectName projectName
+    let remoteProjectId = remoteProject ^. #projectId
+    remoteBranch <- expectRemoteProjectBranchByName remoteProjectId branchName
+    pure (ProjectAndBranch (remoteProjectId, projectName) remoteBranch)
+
+expectRemoteProjectBranchByName :: RemoteProjectId -> ProjectBranchName -> Cli Share.RemoteProjectBranch
+expectRemoteProjectBranchByName remoteProjectId remoteBranchName =
+  Share.getProjectBranchByName (ProjectAndBranch remoteProjectId remoteBranchName) >>= \case
+    Share.GetProjectBranchResponseBranchNotFound -> do
+      loggeth ["The associated remote no longer exists"]
+      Cli.returnEarlyWithoutOutput
+    Share.GetProjectBranchResponseProjectNotFound -> do
+      loggeth ["The associated remote doesn't have a branch named: ", tShow remoteBranchName]
+      Cli.returnEarlyWithoutOutput
+    Share.GetProjectBranchResponseSuccess branch -> pure branch
+
+expectRemoteProjectBranchById :: RemoteProjectId -> RemoteProjectBranchId -> Cli Share.RemoteProjectBranch
+expectRemoteProjectBranchById remoteProjectId remoteProjectBranchId =
+  Share.getProjectBranchById (ProjectAndBranch remoteProjectId remoteProjectBranchId) >>= \case
+    Share.GetProjectBranchResponseBranchNotFound -> do
+      loggeth ["The associated remote no longer exists"]
+      Cli.returnEarlyWithoutOutput
+    Share.GetProjectBranchResponseProjectNotFound -> do
+      loggeth ["The associated remote doesn't have a branch with id: ", tShow remoteProjectBranchId]
+      Cli.returnEarlyWithoutOutput
+    Share.GetProjectBranchResponseSuccess branch -> pure branch

unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs

@@ -6,7 +6,7 @@ module Unison.Codebase.Editor.HandleInput.Push
 where
 
 import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, readTVarIO)
-import Control.Lens (over, to, (^.), _1)
+import Control.Lens (over, (.~), (^.), _1)
 import Control.Monad.Reader (ask)
 import qualified Data.List.NonEmpty as Nel
 import qualified Data.Set.NonEmpty as Set.NonEmpty
@@ -22,6 +22,7 @@ import Unison.Cli.Monad (Cli)
 import qualified Unison.Cli.Monad as Cli
 import qualified Unison.Cli.MonadUtils as Cli
 import Unison.Cli.ProjectUtils (getCurrentProjectBranch, loggeth, projectBranchPath)
+import qualified Unison.Cli.ProjectUtils as ProjectUtils
 import qualified Unison.Cli.Share.Projects as Share
 import qualified Unison.Cli.UnisonConfigUtils as UnisonConfigUtils
 import Unison.Codebase (PushGitBranchOpts (..))
@@ -30,7 +31,13 @@ import Unison.Codebase.Branch (Branch (..))
 import qualified Unison.Codebase.Branch as Branch
 import Unison.Codebase.Editor.HandleInput.AuthLogin (ensureAuthenticatedWithCodeserver)
 import qualified Unison.Codebase.Editor.HandleInput.AuthLogin as AuthLogin
-import Unison.Codebase.Editor.Input (GistInput (..), PushRemoteBranchInput (..), PushSource (..), PushSourceTarget (..), PushTarget (..))
+import Unison.Codebase.Editor.Input
+  ( GistInput (..),
+    PushRemoteBranchInput (..),
+    PushSource (..),
+    PushSourceTarget (..),
+    PushTarget (..),
+  )
 import Unison.Codebase.Editor.Output
 import qualified Unison.Codebase.Editor.Output as Output
 import Unison.Codebase.Editor.Output.PushPull (PushPull (Push))
@@ -72,7 +79,6 @@ import qualified Unison.Share.Sync.Types as Share
 import Unison.Share.Types (codeserverBaseURL)
 import qualified Unison.Sqlite as Sqlite
 import qualified Unison.Sync.Types as Share
-import Witch (unsafeFrom)
 
 -- | Handle a @gist@ command.
 handleGist :: GistInput -> Cli ()
@@ -119,7 +125,7 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior, syncMo
       getCurrentProjectBranch >>= \case
         Nothing -> do
           localPath <- Cli.getCurrentPath
-          remoteProjectAndBranch <- branchNameSpecToNames remoteProjectAndBranch0
+          remoteProjectAndBranch <- ProjectUtils.resolveNames remoteProjectAndBranch0
           pushLooseCodeToProjectBranch localPath remoteProjectAndBranch
         Just localProjectAndBranch ->
           pushProjectBranchToProjectBranch localProjectAndBranch (Just remoteProjectAndBranch0)
@@ -130,65 +136,17 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior, syncMo
     -- push .some.path to @some/project
     PushSourceTarget2 (PathySource localPath0) (ProjyTarget remoteProjectAndBranch0) -> do
       localPath <- Cli.resolvePath' localPath0
-      remoteProjectAndBranch <- branchNameSpecToNames remoteProjectAndBranch0
+      remoteProjectAndBranch <- ProjectUtils.resolveNames remoteProjectAndBranch0
       pushLooseCodeToProjectBranch localPath remoteProjectAndBranch
     -- push @some/project to .some.path
     PushSourceTarget2 (ProjySource localProjectAndBranch0) (PathyTarget remotePath) -> do
-      localProjectAndBranch <- branchNameSpecToIds localProjectAndBranch0
+      localProjectAndBranch <- ProjectUtils.resolveNamesToIds localProjectAndBranch0
       pushLooseCodeToLooseCode (projectBranchPath localProjectAndBranch) remotePath pushBehavior syncMode
     -- push @some/project to @some/project
     PushSourceTarget2 (ProjySource localProjectAndBranch0) (ProjyTarget remoteProjectAndBranch) -> do
-      localProjectAndBranch <- branchNameSpecToIds localProjectAndBranch0
+      localProjectAndBranch <- ProjectUtils.resolveNamesToIds localProjectAndBranch0
       pushProjectBranchToProjectBranch localProjectAndBranch (Just remoteProjectAndBranch)
 
--- Convert a "branch name spec" (project name, or branch name, or both) into local ids for the project and branch, using
--- the following defaults, if a name is missing:
---
---   - The project at the current path
---   - The branch named "main"
-branchNameSpecToIds :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch ProjectId ProjectBranchId)
-branchNameSpecToIds = \case
-  This projectName -> branchNameSpecToIds (These projectName (unsafeFrom @Text "main"))
-  That branchName -> do
-    ProjectAndBranch projectId _branchId <-
-      getCurrentProjectBranch & onNothingM do
-        loggeth ["not on a project branch yo"]
-        Cli.returnEarlyWithoutOutput
-    branch <-
-      Cli.runTransaction (Queries.loadProjectBranchByName projectId (into @Text branchName)) & onNothingM do
-        project <- Cli.runTransaction (Queries.expectProject projectId)
-        Cli.returnEarly $
-          LocalProjectBranchDoesntExist (ProjectAndBranch (unsafeFrom @Text (project ^. #name)) branchName)
-    pure (ProjectAndBranch projectId (branch ^. #branchId))
-  These projectName branchName -> do
-    maybeProjectAndBranch <-
-      Cli.runTransaction do
-        runMaybeT do
-          project <- MaybeT (Queries.loadProjectByName (into @Text projectName))
-          let projectId = project ^. #projectId
-          branch <- MaybeT (Queries.loadProjectBranchByName projectId (into @Text branchName))
-          pure (ProjectAndBranch projectId (branch ^. #branchId))
-    maybeProjectAndBranch & onNothing do
-      Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
-
--- Convert a "branch name spec" (project name, or branch name, or both) into names for the project and branch, using the
--- following defaults, if a name is missing:
---
---   - The project at the current path
---   - The branch named "main"
-branchNameSpecToNames :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch ProjectName ProjectBranchName)
-branchNameSpecToNames = \case
-  This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main"))
-  That branchName -> do
-    ProjectAndBranch projectId _branchId <-
-      getCurrentProjectBranch & onNothingM do
-        loggeth ["not on a project branch"]
-        Cli.returnEarlyWithoutOutput
-    Cli.runTransaction do
-      project <- Queries.expectProject projectId
-      pure (ProjectAndBranch (unsafeFrom @Text (project ^. #name)) branchName)
-  These projectName branchName -> pure (ProjectAndBranch projectName branchName)
-
 -- Push a local namespace ("loose code") to a remote namespace ("loose code").
 pushLooseCodeToLooseCode :: Path.Absolute -> WriteRemotePath -> PushBehavior -> SyncMode -> Cli ()
 pushLooseCodeToLooseCode localPath remotePath pushBehavior syncMode = do
@@ -359,8 +317,8 @@ bazinga50 localProjectAndBranch localBranchHead maybeRemoteBranchName = do
               for maybeRemoteBranchId \remoteBranchId -> do
                 remoteBranchName <-
                   Queries.expectRemoteProjectBranchName Share.hardCodedUri remoteProjectId remoteBranchId
-                pure (remoteBranchId, unsafeFrom @Text remoteBranchName)
-            pure (Just (remoteProjectId, unsafeFrom @Text remoteProjectName, maybeRemoteBranchInfo))
+                pure (remoteBranchId, remoteBranchName)
+            pure (Just (remoteProjectId, remoteProjectName, maybeRemoteBranchInfo))
 
   Cli.runTransaction loadRemoteProjectInfo >>= \case
     Nothing -> bazinga10 localProjectAndBranch localBranchHead (ProjectAndBranch Nothing maybeRemoteBranchName)
@@ -371,7 +329,7 @@ bazinga50 localProjectAndBranch localBranchHead maybeRemoteBranchName = do
             -- "push" with remote mapping for project from ancestor branch
             Nothing -> do
               myUserHandle <- oinkGetLoggedInUser
-              let localBranchName = unsafeFrom @Text (localProjectAndBranch ^. #branch . #name)
+              let localBranchName = localProjectAndBranch ^. #branch . #name
               -- Derive the remote branch name from the user's handle and the local branch name.
               --
               -- user "bob" has local branch "topic":        remoteBranchName = "@bob/topic"
@@ -392,18 +350,20 @@ bazinga50 localProjectAndBranch localBranchHead maybeRemoteBranchName = do
                         Share.hardCodedUri
                         (ProjectAndBranch remoteProjectName remoteBranchName)
               Share.getProjectBranchById (ProjectAndBranch remoteProjectId remoteBranchId) >>= \case
-                Share.API.GetProjectBranchResponseBranchNotFound _ -> remoteProjectBranchDoesntExist
-                Share.API.GetProjectBranchResponseProjectNotFound _ -> remoteProjectBranchDoesntExist
-                Share.API.GetProjectBranchResponseUnauthorized (Share.API.Unauthorized message) ->
-                  Cli.returnEarly (Output.Unauthorized message)
-                Share.API.GetProjectBranchResponseSuccess remoteBranch -> do
-                  remoteBranch1 <- expectRemoteProjectAndBranch remoteBranch
+                Share.GetProjectBranchResponseBranchNotFound -> remoteProjectBranchDoesntExist
+                Share.GetProjectBranchResponseProjectNotFound -> remoteProjectBranchDoesntExist
+                Share.GetProjectBranchResponseSuccess remoteBranch -> do
                   afterUploadAction <-
                     makeFastForwardAfterUploadAction
                       (PushingProjectBranch localProjectAndBranch)
                       localBranchHead
                       remoteBranch
-                  pure UploadPlan {remoteBranch = remoteBranch1, causalHash = localBranchHead, afterUploadAction}
+                  pure
+                    UploadPlan
+                      { remoteBranch = ProjectAndBranch (remoteBranch ^. #projectName) (remoteBranch ^. #branchName),
+                        causalHash = localBranchHead,
+                        afterUploadAction
+                      }
         -- "push /foo" with remote mapping for project from ancestor branch
         Just remoteBranchName ->
           pushToProjectBranch1
@@ -422,8 +382,8 @@ bazinga10 ::
   Cli UploadPlan
 bazinga10 localProjectAndBranch localBranchHead remoteProjectAndBranchMaybes = do
   myUserHandle <- oinkGetLoggedInUser
-  let localProjectName = unsafeFrom @Text (localProjectAndBranch ^. #project . #name)
-  let localBranchName = unsafeFrom @Text (localProjectAndBranch ^. #branch . #name)
+  let localProjectName = localProjectAndBranch ^. #project . #name
+  let localBranchName = localProjectAndBranch ^. #branch . #name
   let remoteProjectName =
         case remoteProjectAndBranchMaybes ^. #project of
           Nothing -> prependUserSlugToProjectName myUserHandle localProjectName
@@ -445,25 +405,28 @@ data WhatAreWePushing
 pushToProjectBranch0 :: WhatAreWePushing -> Hash32 -> ProjectAndBranch ProjectName ProjectBranchName -> Cli UploadPlan
 pushToProjectBranch0 pushing localBranchHead remoteProjectAndBranch = do
   let remoteProjectName = remoteProjectAndBranch ^. #project
-  let remoteBranchName = remoteProjectAndBranch ^. #branch
   Share.getProjectByName remoteProjectName >>= \case
-    Share.API.GetProjectResponseNotFound {} -> do
+    Nothing -> do
+      remoteProject <-
+        Share.createProject remoteProjectName & onNothingM do
+          Cli.returnEarly $
+            Output.RemoteProjectBranchDoesntExist
+              Share.hardCodedUri
+              remoteProjectAndBranch
       pure
         UploadPlan
           { remoteBranch = remoteProjectAndBranch,
             causalHash = localBranchHead,
             afterUploadAction =
-              createProjectAndBranchAfterUploadAction
+              createBranchAfterUploadAction
                 pushing
                 localBranchHead
-                remoteProjectAndBranch
+                (over #project (remoteProject ^. #projectId,) remoteProjectAndBranch)
           }
-    Share.API.GetProjectResponseUnauthorized (Share.API.Unauthorized message) ->
-      Cli.returnEarly (Output.Unauthorized message)
-    Share.API.GetProjectResponseSuccess remoteProject -> do
-      let remoteProjectId = RemoteProjectId (remoteProject ^. #projectId)
-      Share.getProjectBranchByName (ProjectAndBranch remoteProjectId remoteBranchName) >>= \case
-        Share.API.GetProjectBranchResponseBranchNotFound {} -> do
+    Just remoteProject -> do
+      let remoteProjectId = remoteProject ^. #projectId
+      Share.getProjectBranchByName (remoteProjectAndBranch & #project .~ remoteProjectId) >>= \case
+        Share.GetProjectBranchResponseBranchNotFound -> do
           pure
             UploadPlan
               { remoteBranch = remoteProjectAndBranch,
@@ -474,11 +437,9 @@ pushToProjectBranch0 pushing localBranchHead remoteProjectAndBranch = do
                     localBranchHead
                     (over #project (remoteProjectId,) remoteProjectAndBranch)
               }
-        Share.API.GetProjectBranchResponseProjectNotFound {} ->
+        Share.GetProjectBranchResponseProjectNotFound ->
           Cli.returnEarly (Output.RemoteProjectBranchDoesntExist Share.hardCodedUri remoteProjectAndBranch)
-        Share.API.GetProjectBranchResponseUnauthorized (Share.API.Unauthorized message) ->
-          Cli.returnEarly (Output.Unauthorized message)
-        Share.API.GetProjectBranchResponseSuccess remoteBranch -> do
+        Share.GetProjectBranchResponseSuccess remoteBranch -> do
           afterUploadAction <- makeFastForwardAfterUploadAction pushing localBranchHead remoteBranch
           pure
             UploadPlan
@@ -496,7 +457,7 @@ pushToProjectBranch1 ::
   Cli UploadPlan
 pushToProjectBranch1 localProjectAndBranch localBranchHead remoteProjectAndBranch = do
   Share.getProjectBranchByName (over #project fst remoteProjectAndBranch) >>= \case
-    Share.API.GetProjectBranchResponseBranchNotFound {} -> do
+    Share.GetProjectBranchResponseBranchNotFound -> do
       pure
         UploadPlan
           { remoteBranch = over #project snd remoteProjectAndBranch,
@@ -507,10 +468,8 @@ pushToProjectBranch1 localProjectAndBranch localBranchHead remoteProjectAndBranc
                 localBranchHead
                 remoteProjectAndBranch
           }
-    Share.API.GetProjectBranchResponseProjectNotFound {} -> remoteProjectBranchDoesntExist
-    Share.API.GetProjectBranchResponseUnauthorized (Share.API.Unauthorized message) ->
-      Cli.returnEarly (Output.Unauthorized message)
-    Share.API.GetProjectBranchResponseSuccess remoteBranch -> do
+    Share.GetProjectBranchResponseProjectNotFound -> remoteProjectBranchDoesntExist
+    Share.GetProjectBranchResponseSuccess remoteBranch -> do
       afterUploadAction <-
         makeFastForwardAfterUploadAction (PushingProjectBranch localProjectAndBranch) localBranchHead remoteBranch
       pure
@@ -573,32 +532,6 @@ executeUploadPlan UploadPlan {remoteBranch, causalHash, afterUploadAction} = do
 -- An action to call after a successful upload.
 type AfterUploadAction = Cli ()
 
--- An after-upload action that creates a remote project, then a remote branch.
---
--- Precondition: the remote project doesn't exist.
-createProjectAndBranchAfterUploadAction ::
-  WhatAreWePushing ->
-  Hash32 ->
-  ProjectAndBranch ProjectName ProjectBranchName ->
-  AfterUploadAction
-createProjectAndBranchAfterUploadAction pushing localBranchHead remoteProjectAndBranch = do
-  remoteProject <- do
-    let request = Share.API.CreateProjectRequest {projectName = into @Text (remoteProjectAndBranch ^. #project)}
-    Share.createProject request >>= \case
-      Share.API.CreateProjectResponseUnauthorized (Share.API.Unauthorized message) ->
-        Cli.returnEarly (Output.Unauthorized message)
-      Share.API.CreateProjectResponseNotFound _ -> do
-        Cli.returnEarly $
-          Output.RemoteProjectBranchDoesntExist
-            Share.hardCodedUri
-            remoteProjectAndBranch
-      Share.API.CreateProjectResponseSuccess remoteProject -> pure remoteProject
-  let remoteProjectId = RemoteProjectId (remoteProject ^. #projectId)
-  createBranchAfterUploadAction
-    pushing
-    localBranchHead
-    (over #project (remoteProjectId,) remoteProjectAndBranch)
-
 -- An after-upload action that creates a remote branch.
 --
 -- Precondition: the remote project exists, but the remote branch doesn't.
@@ -634,14 +567,9 @@ createBranchAfterUploadAction pushing localBranchHead remoteProjectAndBranch = d
             branchMergeTarget
           }
   remoteBranch <-
-    Share.createProjectBranch createProjectBranchRequest >>= \case
-      Share.API.CreateProjectBranchResponseUnauthorized (Share.API.Unauthorized message) ->
-        Cli.returnEarly (Output.Unauthorized message)
-      Share.API.CreateProjectBranchResponseNotFound _ ->
-        Cli.returnEarly $
-          Output.RemoteProjectBranchDoesntExist Share.hardCodedUri (over #project snd remoteProjectAndBranch)
-      Share.API.CreateProjectBranchResponseMissingCausalHash hash -> bugRemoteMissingCausalHash hash
-      Share.API.CreateProjectBranchResponseSuccess remoteBranch -> pure remoteBranch
+    Share.createProjectBranch createProjectBranchRequest & onNothingM do
+      Cli.returnEarly $
+        Output.RemoteProjectBranchDoesntExist Share.hardCodedUri (over #project snd remoteProjectAndBranch)
   case pushing of
     PushingLooseCode -> pure ()
     PushingProjectBranch (ProjectAndBranch localProject localBranch) ->
@@ -651,9 +579,9 @@ createBranchAfterUploadAction pushing localBranchHead remoteProjectAndBranch = d
         Queries.ensureBranchRemoteMapping
           (localProject ^. #projectId)
           (localBranch ^. #branchId)
-          (RemoteProjectId (remoteBranch ^. #projectId))
+          (remoteBranch ^. #projectId)
           Share.hardCodedUri
-          (RemoteProjectBranchId (remoteBranch ^. #branchId))
+          (remoteBranch ^. #branchId)
 
 -- We intend to fast-forward a remote branch. There's one last check to do, which may cause this action to
 -- short-circuit: check to see if the remote branch is indeed behind the given causal hash. If it is, then return an
@@ -661,14 +589,10 @@ createBranchAfterUploadAction pushing localBranchHead remoteProjectAndBranch = d
 makeFastForwardAfterUploadAction ::
   WhatAreWePushing ->
   Hash32 ->
-  Share.API.ProjectBranch ->
+  Share.RemoteProjectBranch ->
   Cli AfterUploadAction
 makeFastForwardAfterUploadAction pushing localBranchHead remoteBranch = do
-  let remoteProjectAndBranchNames =
-        ProjectAndBranch
-          (unsafeFrom @Text (remoteBranch ^. #projectName))
-          (unsafeFrom @Text (remoteBranch ^. #branchName))
-
+  let remoteProjectAndBranchNames = ProjectAndBranch (remoteBranch ^. #projectName) (remoteBranch ^. #branchName)
   let remoteProjectBranchHeadMismatch :: Cli a
       remoteProjectBranchHeadMismatch =
         Cli.returnEarly (RemoteProjectBranchHeadMismatch Share.hardCodedUri remoteProjectAndBranchNames)
@@ -679,20 +603,17 @@ makeFastForwardAfterUploadAction pushing localBranchHead remoteBranch = do
   pure do
     let request =
           Share.API.SetProjectBranchHeadRequest
-            { projectId = remoteBranch ^. #projectId,
-              branchId = remoteBranch ^. #branchId,
+            { projectId = unRemoteProjectId (remoteBranch ^. #projectId),
+              branchId = unRemoteProjectBranchId (remoteBranch ^. #branchId),
               branchOldCausalHash = Just remoteBranchHead,
               branchNewCausalHash = localBranchHead
             }
     Share.setProjectBranchHead request >>= \case
-      Share.API.SetProjectBranchHeadResponseUnauthorized (Share.API.Unauthorized message) ->
-        Cli.returnEarly (Output.Unauthorized message)
-      Share.API.SetProjectBranchHeadResponseNotFound _ -> do
-        Cli.returnEarly (Output.RemoteProjectBranchDoesntExist Share.hardCodedUri remoteProjectAndBranchNames)
-      Share.API.SetProjectBranchHeadResponseMissingCausalHash hash -> bugRemoteMissingCausalHash hash
-      Share.API.SetProjectBranchHeadResponseExpectedCausalHashMismatch _expected _actual ->
+      Share.SetProjectBranchHeadResponseExpectedCausalHashMismatch _expected _actual ->
         remoteProjectBranchHeadMismatch
-      Share.API.SetProjectBranchHeadResponseSuccess -> do
+      Share.SetProjectBranchHeadResponseNotFound -> do
+        Cli.returnEarly (Output.RemoteProjectBranchDoesntExist Share.hardCodedUri remoteProjectAndBranchNames)
+      Share.SetProjectBranchHeadResponseSuccess -> do
         case pushing of
           PushingLooseCode -> pure ()
           PushingProjectBranch (ProjectAndBranch localProject localBranch) -> do
@@ -700,17 +621,13 @@ makeFastForwardAfterUploadAction pushing localBranchHead remoteBranch = do
               Queries.ensureBranchRemoteMapping
                 (localProject ^. #projectId)
                 (localBranch ^. #branchId)
-                (remoteBranch ^. #projectId . to RemoteProjectId)
+                (remoteBranch ^. #projectId)
                 Share.hardCodedUri
-                (remoteBranch ^. #branchId . to RemoteProjectBranchId)
+                (remoteBranch ^. #branchId)
   where
     remoteBranchHead =
       Share.API.hashJWTHash (remoteBranch ^. #branchHead)
 
-bugRemoteMissingCausalHash :: Hash32 -> a
-bugRemoteMissingCausalHash hash =
-  error (reportBug "E796475" ("Create remote branch: causal hash missing: " ++ show hash))
-
 oinkGetLoggedInUser :: Cli Text
 oinkGetLoggedInUser = do
   loggeth ["Getting current logged-in user on Share"]
@@ -770,36 +687,3 @@ wouldNotBeFastForward localBranchHead remoteBranchHead = do
   case maybeHashIds of
     Nothing -> pure True
     Just (localBranchHead1, remoteBranchHead1) -> not <$> Queries.before remoteBranchHead1 localBranchHead1
-
-------------------------------------------------------------------------------------------------------------------------
--- Extracting things out of Share project/branch names
---
--- A Share project is just an opaque text, but we often need to assert that it actually is of the form @user/name
-
-expectRemoteProjectAndBranch :: Share.API.ProjectBranch -> Cli (ProjectAndBranch ProjectName ProjectBranchName)
-expectRemoteProjectAndBranch branch = do
-  projectName <- expectProjectName (branch ^. #projectName)
-  branchName <- expectBranchName (branch ^. #branchName)
-  pure (ProjectAndBranch projectName branchName)
-
-expectProjectName :: Text -> Cli ProjectName
-expectProjectName projectName =
-  case tryInto projectName of
-    -- This shouldn't happen often - Share gave us a project name that we don't consider valid?
-    Left err -> do
-      loggeth ["Invalid project name: ", tShow err]
-      Cli.returnEarlyWithoutOutput
-    Right x -> pure x
-
-expectBranchName :: Text -> Cli ProjectBranchName
-expectBranchName branchName = case tryInto branchName of
-  Left err -> do
-    loggeth
-      [ "Expected text: ",
-        tShow branchName,
-        " to be a valid project branch name.",
-        "\n",
-        tShow err
-      ]
-    Cli.returnEarlyWithoutOutput
-  Right x -> pure x

unison-cli/src/Unison/Codebase/Editor/Input.hs

@@ -2,6 +2,8 @@ module Unison.Codebase.Editor.Input
   ( Input (..),
     DiffNamespaceToPatchInput (..),
     GistInput (..),
+    PullSourceTarget (..),
+    PullTarget (..),
     PushRemoteBranchInput (..),
     PushSourceTarget (..),
     PushTarget (..),
@@ -97,10 +99,15 @@ data Input
     MergeLocalBranchI Path' Path' Branch.MergeMode
   | PreviewMergeLocalBranchI Path' Path'
   | DiffNamespaceI BranchId BranchId -- old new
-  | PullRemoteBranchI (Maybe ReadRemoteNamespace) Path' SyncMode PullMode Verbosity
+  | PullRemoteBranchI PullSourceTarget SyncMode PullMode Verbosity
   | PushRemoteBranchI PushRemoteBranchInput
-  | CreatePullRequestI ReadRemoteNamespace ReadRemoteNamespace
-  | LoadPullRequestI ReadRemoteNamespace ReadRemoteNamespace Path'
+  | CreatePullRequestI
+      (ReadRemoteNamespace (These ProjectName ProjectBranchName))
+      (ReadRemoteNamespace (These ProjectName ProjectBranchName))
+  | LoadPullRequestI
+      (ReadRemoteNamespace (These ProjectName ProjectBranchName))
+      (ReadRemoteNamespace (These ProjectName ProjectBranchName))
+      Path'
   | ResetRootI (Either ShortCausalHash Path')
   | -- todo: Q: Does it make sense to publish to not-the-root of a Github repo?
     --          Does it make sense to fork from not-the-root of a Github repo?
@@ -166,8 +173,8 @@ data Input
     CompileSchemeI String (HQ.HashQualified Name)
   | -- generate scheme libraries
     GenSchemeLibsI
-  | -- fetch scheme compiler
-    FetchSchemeCompilerI
+  | -- fetch scheme compiler from a given username
+    FetchSchemeCompilerI String
   | TestI TestInput
   | -- metadata
     -- `link metadata definitions` (adds metadata to all of `definitions`)
@@ -234,6 +241,21 @@ data GistInput = GistInput
   }
   deriving stock (Eq, Show)
 
+-- | Pull source and target: either neither is specified, or only a source, or both.
+data PullSourceTarget
+  = PullSourceTarget0
+  | PullSourceTarget1 (ReadRemoteNamespace (These ProjectName ProjectBranchName))
+  | PullSourceTarget2
+      (ReadRemoteNamespace (These ProjectName ProjectBranchName))
+      (PullTarget (These ProjectName ProjectBranchName))
+  deriving stock (Eq, Show)
+
+-- | Where are we pulling into?
+data PullTarget a
+  = PullTargetLooseCode Path'
+  | PullTargetProject a
+  deriving stock (Eq, Show)
+
 data PushTarget
   = PathyTarget WriteRemotePath
   | ProjyTarget (These ProjectName ProjectBranchName)

unison-cli/src/Unison/Codebase/Editor/Output.hs

@@ -90,7 +90,7 @@ data NumberedOutput
   | ShowDiffAfterMergePropagate Path.Path' Path.Absolute Path.Path' PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
   | ShowDiffAfterMergePreview Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
   | ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
-  | ShowDiffAfterCreatePR ReadRemoteNamespace ReadRemoteNamespace PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
+  | ShowDiffAfterCreatePR (ReadRemoteNamespace Void) (ReadRemoteNamespace Void) PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
   | -- <authorIdentifier> <authorPath> <relativeBase>
     ShowDiffAfterCreateAuthor NameSegment Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
   | -- | Invariant: there's at least one conflict or edit in the TodoOutput.
@@ -136,7 +136,7 @@ data Output
       -- ^ acceptable type(s) of function
   | BranchEmpty WhichBranchEmpty
   | BranchNotEmpty Path'
-  | LoadPullRequest ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path'
+  | LoadPullRequest (ReadRemoteNamespace Void) (ReadRemoteNamespace Void) Path' Path' Path' Path'
   | CreatedNewBranch Path.Absolute
   | BranchAlreadyExists Path'
   | FindNoLocalMatches
@@ -246,10 +246,14 @@ data Output
   | WarnIncomingRootBranch ShortCausalHash (Set ShortCausalHash)
   | StartOfCurrentPathHistory
   | ShowReflog [(Maybe UTCTime, SCH.ShortCausalHash, Text)]
-  | PullAlreadyUpToDate ReadRemoteNamespace Path'
-  | PullSuccessful ReadRemoteNamespace Path'
+  | PullAlreadyUpToDate
+      (ReadRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName))
+      (PullTarget (ProjectAndBranch ProjectName ProjectBranchName))
+  | PullSuccessful
+      (ReadRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName))
+      (PullTarget (ProjectAndBranch ProjectName ProjectBranchName))
   | -- | Indicates a trivial merge where the destination was empty and was just replaced.
-    MergeOverEmpty Path'
+    MergeOverEmpty (PullTarget (ProjectAndBranch ProjectName ProjectBranchName))
   | MergeAlreadyUpToDate Path' Path'
   | PreviewMergeAlreadyUpToDate Path' Path'
   | -- | No conflicts or edits remain for the current patch.
@@ -276,7 +280,7 @@ data Output
   | -- Refused to push, either because a `push` targeted an empty namespace, or a `push.create` targeted a non-empty namespace.
     RefusedToPush PushBehavior WriteRemotePath
   | -- | @GistCreated repo@ means a causal was just published to @repo@.
-    GistCreated ReadRemoteNamespace
+    GistCreated (ReadRemoteNamespace Void)
   | -- | Directs the user to URI to begin an authorization flow.
     InitiateAuthFlow URI
   | UnknownCodeServer Text
@@ -286,7 +290,7 @@ data Output
   | DisplayDebugNameDiff NameChanges
   | DisplayDebugCompletions [Completion.Completion]
   | ClearScreen
-  | PulledEmptyBranch ReadRemoteNamespace
+  | PulledEmptyBranch (ReadRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName))
   | ProjectNameAlreadyExists ProjectName
   | ProjectAndBranchNameAlreadyExists (ProjectAndBranch ProjectName ProjectBranchName)
   | LocalProjectBranchDoesntExist (ProjectAndBranch ProjectName ProjectBranchName)

unison-cli/src/Unison/Codebase/Editor/Propagate.hs

@@ -559,7 +559,7 @@ typecheckFile ::
   Codebase m Symbol Ann ->
   [Type Symbol Ann] ->
   UF.UnisonFile Symbol Ann ->
-  Sqlite.Transaction (Result.Result (Seq (Result.Note Symbol Ann)) (Either Names (UF.TypecheckedUnisonFile Symbol Ann)))
+  Sqlite.Transaction (Result.Result (Seq (Result.Note Symbol Ann)) (Either x (UF.TypecheckedUnisonFile Symbol Ann)))
 typecheckFile codebase ambient file = do
   typeLookup <- Codebase.typeLookupForDependencies codebase (UF.dependencies file)
   pure . fmap Right $ synthesizeFile' ambient (typeLookup <> Builtin.typeLookup) file

unison-cli/src/Unison/Codebase/Editor/UriParser.hs

@@ -12,6 +12,7 @@ import Data.Bifunctor (first)
 import Data.Char (isAlphaNum, isDigit, isSpace)
 import Data.Sequence as Seq
 import qualified Data.Text as Text
+import Data.These (These)
 import Data.Void
 import qualified Text.Megaparsec as P
 import qualified Text.Megaparsec.Char as C
@@ -33,6 +34,7 @@ import qualified Unison.Codebase.Path as Path
 import Unison.Codebase.ShortCausalHash (ShortCausalHash (..))
 import Unison.NameSegment (NameSegment (..))
 import Unison.Prelude
+import Unison.Project (ProjectBranchName, ProjectName)
 import qualified Unison.Syntax.Lexer
 import qualified Unison.Util.Pretty as P
 import qualified Unison.Util.Pretty.MegaParsec as P
@@ -57,13 +59,17 @@ type P = P.Parsec Void Text.Text
 
 -- $ git clone [user@]server:project.git[:treeish][:[#hash][.path]]
 
-repoPath :: P ReadRemoteNamespace
+repoPath :: P (ReadRemoteNamespace (These ProjectName ProjectBranchName))
 repoPath =
   P.label "generic repo" $
     fmap ReadRemoteNamespaceGit readGitRemoteNamespace
       <|> fmap ReadRemoteNamespaceShare readShareRemoteNamespace
+      <|> wundefined
 
-parseReadRemoteNamespace :: String -> String -> Either (P.Pretty P.ColorText) ReadRemoteNamespace
+parseReadRemoteNamespace ::
+  String ->
+  String ->
+  Either (P.Pretty P.ColorText) (ReadRemoteNamespace (These ProjectName ProjectBranchName))
 parseReadRemoteNamespace label input =
   let printError err = P.lines [P.string "I couldn't parse the repository address given above.", P.prettyPrintParseError input err]
    in first printError (P.parse repoPath label (Text.pack input))

unison-cli/src/Unison/Codebase/TranscriptParser.hs

@@ -18,7 +18,7 @@ module Unison.Codebase.TranscriptParser
   )
 where
 
-import Control.Lens ((?~), (^.))
+import Control.Lens (use, (?=), (^.))
 import qualified Crypto.Random as Random
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Encode.Pretty as Aeson
@@ -30,6 +30,7 @@ import Data.IORef
 import Data.List (isSubsequenceOf)
 import qualified Data.Map as Map
 import qualified Data.Text as Text
+import Data.These (These (..))
 import qualified Ki
 import qualified Network.HTTP.Client as HTTP
 import System.Directory (doesFileExist)
@@ -42,7 +43,10 @@ import qualified U.Codebase.Sqlite.Operations as Operations
 import qualified Unison.Auth.CredentialManager as AuthN
 import qualified Unison.Auth.HTTPClient as AuthN
 import qualified Unison.Auth.Tokens as AuthN
+import Unison.Cli.Monad (Cli)
 import qualified Unison.Cli.Monad as Cli
+import qualified Unison.Cli.MonadUtils as Cli
+import qualified Unison.Cli.ProjectUtils as ProjectUtils
 import Unison.Codebase (Codebase)
 import qualified Unison.Codebase as Codebase
 import qualified Unison.Codebase.Branch.Type as Branch
@@ -61,6 +65,7 @@ import Unison.CommandLine.Welcome (asciiartUnison)
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
 import Unison.PrettyTerminal
+import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
 import qualified Unison.Runtime.Interface as RTI
 import qualified Unison.Server.Backend as Backend
 import qualified Unison.Server.CodebaseServer as Server
@@ -93,9 +98,14 @@ data Hidden = Shown | HideOutput | HideAll
   deriving (Eq, Show)
 
 data UcmLine
-  = UcmCommand Path.Absolute Text
+  = UcmCommand UcmContext Text
   | UcmComment Text -- Text does not include the '--' prefix.
 
+-- | Where a command is run: either loose code (.foo.bar.baz>) or a project branch (myproject/mybranch>).
+data UcmContext
+  = UcmContextLooseCode Path.Absolute
+  | UcmContextProject (ProjectAndBranch ProjectName ProjectBranchName)
+
 data APIRequest
   = GetRequest Text
   | APIComment Text
@@ -112,8 +122,13 @@ data Stanza
   | Unfenced Text
 
 instance Show UcmLine where
-  show (UcmCommand path txt) = show path <> ">" <> Text.unpack txt
-  show (UcmComment txt) = "--" ++ Text.unpack txt
+  show = \case
+    UcmCommand context txt -> showContext context <> "> " <> Text.unpack txt
+    UcmComment txt -> "--" ++ Text.unpack txt
+    where
+      showContext = \case
+        UcmContextLooseCode path -> show path
+        UcmContextProject (ProjectAndBranch project branch) -> Text.unpack (into @Text (These project branch))
 
 instance Show Stanza where
   show s = case s of
@@ -166,7 +181,7 @@ parseFile filePath = do
 parse :: String -> Text -> Either TranscriptError [Stanza]
 parse srcName txt = case P.parse (stanzas <* P.eof) srcName txt of
   Right a -> Right a
-  Left e -> Left . TranscriptParseError $ tShow e
+  Left e -> Left . TranscriptParseError . Text.pack . P.errorBundlePretty $ e
 
 type TranscriptRunner =
   ( String ->
@@ -183,26 +198,27 @@ withTranscriptRunner ::
   (TranscriptRunner -> m r) ->
   m r
 withTranscriptRunner ucmVersion configFile action = do
-  withRuntimes $ \runtime sbRuntime -> withConfig $ \config -> do
-    action $ \transcriptName transcriptSrc (codebaseDir, codebase) -> do
+  withRuntimes \runtime sbRuntime -> withConfig $ \config -> do
+    action \transcriptName transcriptSrc (codebaseDir, codebase) -> do
       Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) Server.defaultCodebaseServerOpts runtime codebase $ \baseUrl -> do
         let parsed = parse transcriptName transcriptSrc
-        result <- for parsed $ \stanzas -> do
+        result <- for parsed \stanzas -> do
           liftIO $ run codebaseDir stanzas codebase runtime sbRuntime config ucmVersion (tShow baseUrl)
         pure $ join @(Either TranscriptError) result
   where
     withRuntimes :: ((Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> m a) -> m a)
     withRuntimes action =
-      RTI.withRuntime False RTI.Persistent ucmVersion $ \runtime -> do
-        RTI.withRuntime True RTI.Persistent ucmVersion $ \sbRuntime -> do
+      RTI.withRuntime False RTI.Persistent ucmVersion \runtime -> do
+        RTI.withRuntime True RTI.Persistent ucmVersion \sbRuntime -> do
           action runtime sbRuntime
     withConfig :: forall a. ((Maybe Config -> m a) -> m a)
     withConfig action = do
       case configFile of
         Nothing -> action Nothing
         Just configFilePath -> do
-          let loadConfig = liftIO $ do
-                catchIOError (watchConfig configFilePath) $
+          let loadConfig = liftIO do
+                catchIOError
+                  (watchConfig configFilePath)
                   \_ -> die "Your .unisonConfig could not be loaded. Check that it's correct!"
           UnliftIO.bracket
             loadConfig
@@ -268,7 +284,7 @@ run dir stanzas codebase runtime sbRuntime config ucmVersion baseURL = UnliftIO.
         HideOutput -> True && (not inputEcho)
         HideAll -> True
 
-      output, outputEcho :: (String -> IO ())
+      output, outputEcho :: String -> IO ()
       output = output' False
       outputEcho = output' True
 
@@ -276,8 +292,8 @@ run dir stanzas codebase runtime sbRuntime config ucmVersion baseURL = UnliftIO.
       apiRequest req = do
         output (show req <> "\n")
         case req of
-          (APIComment {}) -> pure ()
-          (GetRequest path) -> do
+          APIComment {} -> pure ()
+          GetRequest path -> do
             req <- case HTTP.parseRequest (Text.unpack $ baseURL <> path) of
               Left err -> dieWithMsg (show err)
               Right req -> pure req
@@ -288,86 +304,102 @@ run dir stanzas codebase runtime sbRuntime config ucmVersion baseURL = UnliftIO.
                 output . (<> "\n") . BL.unpack $ prettyBytes
               Left err -> dieWithMsg ("Error decoding response from " <> Text.unpack path <> ": " <> err)
 
-      awaitInput :: Cli.LoopState -> IO (Either Event Input)
-      awaitInput loopState = do
+      awaitInput :: Cli (Either Event Input)
+      awaitInput = do
         cmd <- atomically (Q.tryDequeue cmdQueue)
         case cmd of
           -- end of ucm block
           Just Nothing -> do
-            output "\n```\n"
+            liftIO (output "\n```\n")
             -- We clear the file cache after each `ucm` stanza, so
             -- that `load` command can read the file written by `edit`
             -- rather than hitting the cache.
-            writeIORef unisonFiles Map.empty
-            dieUnexpectedSuccess
-            awaitInput loopState
+            liftIO (writeIORef unisonFiles Map.empty)
+            liftIO dieUnexpectedSuccess
+            awaitInput
           -- ucm command to run
           Just (Just ucmLine) -> do
             case ucmLine of
               p@(UcmComment {}) -> do
-                output ("\n" <> show p)
-                awaitInput loopState
-              p@(UcmCommand path lineTxt) -> do
-                let curPath = loopState ^. #currentPath
-                if curPath /= path
-                  then do
-                    atomically $ Q.undequeue cmdQueue (Just p)
-                    pure $ Right (SwitchBranchI $ Just (Path.absoluteToPath' path))
-                  else case words . Text.unpack $ lineTxt of
-                    [] -> awaitInput loopState
-                    args -> do
-                      output ("\n" <> show p <> "\n")
-                      let getRoot = fmap Branch.head . atomically $ readTMVar (loopState ^. #root)
-                      parseInput getRoot curPath (loopState ^. #numberedArgs) patternMap args >>= \case
-                        -- invalid command is treated as a failure
-                        Left msg -> dieWithMsg $ Pretty.toPlain terminalWidth msg
-                        Right input -> pure $ Right input
+                liftIO (output ("\n" <> show p))
+                awaitInput
+              p@(UcmCommand context lineTxt) -> do
+                curPath <- Cli.getCurrentPath
+                -- We're either going to run the command now (because we're in the right context), else we'll switch to
+                -- the right context first, then run the command next.
+                maybeSwitchCommand <-
+                  case context of
+                    UcmContextLooseCode path ->
+                      if curPath == path
+                        then pure Nothing
+                        else do
+                          atomically $ Q.undequeue cmdQueue (Just p)
+                          pure $ Just (SwitchBranchI $ Just (Path.absoluteToPath' path))
+                    UcmContextProject projectNames -> do
+                      projectIds <- ProjectUtils.resolveNamesToIds (These (projectNames ^. #project) (projectNames ^. #branch))
+                      if curPath == ProjectUtils.projectBranchPath projectIds
+                        then pure Nothing
+                        else undefined
+                case maybeSwitchCommand of
+                  Just switchCommand -> pure (Right switchCommand)
+                  Nothing -> do
+                    case words . Text.unpack $ lineTxt of
+                      [] -> awaitInput
+                      args -> do
+                        liftIO (output ("\n" <> show p <> "\n"))
+                        rootVar <- use #root
+                        numberedArgs <- use #numberedArgs
+                        let getRoot = fmap Branch.head . atomically $ readTMVar rootVar
+                        liftIO (parseInput getRoot curPath numberedArgs patternMap args) >>= \case
+                          -- invalid command is treated as a failure
+                          Left msg -> liftIO (dieWithMsg $ Pretty.toPlain terminalWidth msg)
+                          Right input -> pure $ Right input
           Nothing -> do
-            dieUnexpectedSuccess
-            writeIORef hidden Shown
-            writeIORef allowErrors False
+            liftIO (dieUnexpectedSuccess)
+            liftIO (writeIORef hidden Shown)
+            liftIO (writeIORef allowErrors False)
             maybeStanza <- atomically (Q.tryDequeue inputQueue)
-            _ <- writeIORef mStanza maybeStanza
+            _ <- liftIO (writeIORef mStanza maybeStanza)
             case maybeStanza of
               Nothing -> do
-                putStrLn ""
+                liftIO (putStrLn "")
                 pure $ Right QuitI
               Just (s, idx) -> do
-                putStr $
+                liftIO . putStr $
                   "\r⚙️   Processing stanza "
                     ++ show idx
                     ++ " of "
                     ++ show (length stanzas)
                     ++ "."
-                IO.hFlush IO.stdout
+                liftIO (IO.hFlush IO.stdout)
                 case s of
                   Unfenced _ -> do
-                    output $ show s
-                    awaitInput loopState
+                    liftIO (output $ show s)
+                    awaitInput
                   UnprocessedFence _ _ -> do
-                    output $ show s
-                    awaitInput loopState
+                    liftIO (output $ show s)
+                    awaitInput
                   Unison hide errOk filename txt -> do
-                    writeIORef hidden hide
-                    outputEcho $ show s
-                    writeIORef allowErrors errOk
-                    output "```ucm\n"
+                    liftIO (writeIORef hidden hide)
+                    liftIO (outputEcho $ show s)
+                    liftIO (writeIORef allowErrors errOk)
+                    liftIO (output "```ucm\n")
                     atomically . Q.enqueue cmdQueue $ Nothing
-                    modifyIORef' unisonFiles (Map.insert (fromMaybe "scratch.u" filename) txt)
+                    liftIO (modifyIORef' unisonFiles (Map.insert (fromMaybe "scratch.u" filename) txt))
                     pure $ Left (UnisonFileChanged (fromMaybe "scratch.u" filename) txt)
                   API apiRequests -> do
-                    output "```api\n"
-                    for_ apiRequests apiRequest
-                    output "```"
-                    awaitInput loopState
+                    liftIO (output "```api\n")
+                    liftIO (for_ apiRequests apiRequest)
+                    liftIO (output "```")
+                    awaitInput
                   Ucm hide errOk cmds -> do
-                    writeIORef hidden hide
-                    writeIORef allowErrors errOk
-                    writeIORef hasErrors False
-                    output "```ucm"
+                    liftIO (writeIORef hidden hide)
+                    liftIO (writeIORef allowErrors errOk)
+                    liftIO (writeIORef hasErrors False)
+                    liftIO (output "```ucm")
                     traverse_ (atomically . Q.enqueue cmdQueue . Just) cmds
                     atomically . Q.enqueue cmdQueue $ Nothing
-                    awaitInput loopState
+                    awaitInput
 
       loadPreviousUnisonBlock name = do
         ufs <- readIORef unisonFiles
@@ -465,20 +497,19 @@ run dir stanzas codebase runtime sbRuntime config ucmVersion baseURL = UnliftIO.
             ucmVersion
           }
 
+  let step :: Cli ()
+      step = do
+        input <- awaitInput
+        case input of
+          Left _ -> pure ()
+          Right inp -> #lastInput ?= inp
+        HandleInput.loop input
+
   let loop :: Cli.LoopState -> IO Text
       loop s0 = do
-        input <- awaitInput s0
-        Cli.runCli env s0 (HandleInput.loop input) >>= \case
-          (Cli.Success (), s1) -> do
-            let sNext = case input of
-                  Left _ -> s1
-                  Right inp -> s1 & #lastInput ?~ inp
-            loop sNext
-          (Cli.Continue, s1) -> do
-            let sNext = case input of
-                  Left _ -> s1
-                  Right inp -> s1 & #lastInput ?~ inp
-            loop sNext
+        Cli.runCli env s0 step >>= \case
+          (Cli.Success (), s1) -> loop s1
+          (Cli.Continue, s1) -> loop s1
           (Cli.HaltRepl, _) -> do
             texts <- readIORef out
             pure $ Text.concat (Text.pack <$> toList (texts :: Seq String))
@@ -490,11 +521,11 @@ transcriptFailure out msg = do
   texts <- readIORef out
   UnliftIO.throwIO
     . TranscriptRunFailure
-    $ Text.concat (Text.pack <$> toList (texts :: Seq String))
+    $ Text.concat (Text.pack <$> toList texts)
       <> "\n\n"
       <> msg
 
-type P = P.Parsec () Text
+type P = P.Parsec Void Text
 
 stanzas :: P [Stanza]
 stanzas = P.many (fenced <|> unfenced)
@@ -504,15 +535,18 @@ ucmLine = ucmCommand <|> ucmComment
   where
     ucmCommand :: P UcmLine
     ucmCommand = do
-      P.lookAhead (word ".")
-      path <- P.takeWhile1P Nothing (/= '>')
-      void $ word ">"
+      context <-
+        P.try do
+          contextString <- P.takeWhile1P Nothing (/= '>')
+          context <-
+            case (tryFrom @Text contextString, Path.parsePath' (Text.unpack contextString)) of
+              (Right (These project branch), _) -> pure (UcmContextProject (ProjectAndBranch project branch))
+              (Left _, Right (Path.unPath' -> Left abs)) -> pure (UcmContextLooseCode abs)
+              _ -> fail "expected project/branch or absolute path"
+          void $ lineToken $ word ">"
+          pure context
       line <- P.takeWhileP Nothing (/= '\n') <* spaces
-      path <- case Path.parsePath' (Text.unpack path) of
-        Right (Path.unPath' -> Left abs) -> pure abs
-        Right _ -> fail "expected absolute path"
-        Left e -> fail e
-      pure $ UcmCommand path line
+      pure $ UcmCommand context line
 
     ucmComment :: P UcmLine
     ucmComment = do
@@ -611,7 +645,7 @@ lineToken :: P a -> P a
 lineToken p = p <* nonNewlineSpaces
 
 nonNewlineSpaces :: P ()
-nonNewlineSpaces = void $ P.takeWhileP Nothing (\ch -> ch `elem` (" \t" :: String))
+nonNewlineSpaces = void $ P.takeWhileP Nothing (\ch -> ch == ' ' || ch == '\t')
 
 hidden :: P Hidden
 hidden = (\case Just x -> x; Nothing -> Shown) <$> optional go

unison-cli/src/Unison/CommandLine/InputPatterns.hs

@@ -1065,14 +1065,19 @@ pullImpl name aliases verbosity pullMode addendum = do
         )
         ( \case
             [] ->
-              Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.ShortCircuit pullMode verbosity
-            [url] -> do
-              ns <- parseReadRemoteNamespace "remote-namespace" url
-              Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.ShortCircuit pullMode verbosity
-            [url, path] -> do
-              ns <- parseReadRemoteNamespace "remote-namespace" url
-              p <- first fromString $ Path.parsePath' path
-              Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.ShortCircuit pullMode verbosity
+              Right $ Input.PullRemoteBranchI Input.PullSourceTarget0 SyncMode.ShortCircuit pullMode verbosity
+            [sourceString] -> do
+              source <- parseReadRemoteNamespace "remote-namespace" sourceString
+              Right $ Input.PullRemoteBranchI (Input.PullSourceTarget1 source) SyncMode.ShortCircuit pullMode verbosity
+            [sourceString, targetString] -> do
+              source <- parseReadRemoteNamespace "remote-namespace" sourceString
+              target <- parsePullTarget targetString
+              Right $
+                Input.PullRemoteBranchI
+                  (Input.PullSourceTarget2 source target)
+                  SyncMode.ShortCircuit
+                  pullMode
+                  verbosity
             _ -> Left (I.help self)
         )
 
@@ -1096,14 +1101,29 @@ pullExhaustive =
     )
     ( \case
         [] ->
-          Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.Complete Input.PullWithHistory Verbosity.Verbose
-        [url] -> do
-          ns <- parseReadRemoteNamespace "remote-namespace" url
-          Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.Complete Input.PullWithHistory Verbosity.Verbose
-        [url, path] -> do
-          ns <- parseReadRemoteNamespace "remote-namespace" url
-          p <- first fromString $ Path.parsePath' path
-          Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.Complete Input.PullWithHistory Verbosity.Verbose
+          Right $
+            Input.PullRemoteBranchI
+              Input.PullSourceTarget0
+              SyncMode.Complete
+              Input.PullWithHistory
+              Verbosity.Verbose
+        [sourceString] -> do
+          source <- parseReadRemoteNamespace "remote-namespace" sourceString
+          Right $
+            Input.PullRemoteBranchI
+              (Input.PullSourceTarget1 source)
+              SyncMode.Complete
+              Input.PullWithHistory
+              Verbosity.Verbose
+        [sourceString, targetString] -> do
+          source <- parseReadRemoteNamespace "remote-namespace" sourceString
+          target <- parsePullTarget targetString
+          Right $
+            Input.PullRemoteBranchI
+              (Input.PullSourceTarget2 source target)
+              SyncMode.Complete
+              Input.PullWithHistory
+              Verbosity.Verbose
         _ -> Left (I.help pullVerbose)
     )
 
@@ -2181,12 +2201,16 @@ fetchScheme =
               <> "is run\
                  \ if the library is not already in the standard location\
                  \ (unison.internal). However, this command will force\
-                 \ a pull even if the library already exists."
+                 \ a pull even if the library already exists. You can also specify\
+                 \ a username to pull from (the default is `unison`) to use an alternate\
+                 \ implementation of the scheme compiler. It will attempt to fetch\
+                 \ [username].public.internal.trunk for use."
           )
         ]
     )
     ( \case
-        [] -> pure Input.FetchSchemeCompilerI
+        [] -> pure (Input.FetchSchemeCompilerI "unison")
+        [name] -> pure (Input.FetchSchemeCompilerI name)
         _ -> Left $ showPatternHelp fetchScheme
     )
 
@@ -2622,6 +2646,15 @@ parseProjectBranchName :: Text -> Either (P.Pretty P.ColorText) ProjectBranchNam
 parseProjectBranchName s =
   mapLeft (\_ -> "Invalid branch name.") (tryInto @ProjectBranchName s)
 
+parsePullTarget :: String -> Either (P.Pretty CT.ColorText) (Input.PullTarget (These ProjectName ProjectBranchName))
+parsePullTarget targetString =
+  case tryInto @(These ProjectName ProjectBranchName) (Text.pack targetString) of
+    Left _ ->
+      case Path.parsePath' targetString of
+        Left _ -> Left (I.help pull)
+        Right path -> pure (Input.PullTargetLooseCode path)
+    Right project -> pure (Input.PullTargetProject project)
+
 -- | Parse a 'Input.PushSource'.
 parsePushSource :: String -> Either (P.Pretty CT.ColorText) Input.PushSource
 parsePushSource sourceStr =

unison-cli/src/Unison/CommandLine/Main.hs

@@ -46,7 +46,7 @@ import qualified Unison.CommandLine.Welcome as Welcome
 import Unison.Parser.Ann (Ann)
 import Unison.Prelude
 import Unison.PrettyTerminal
-import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
+import Unison.Project (ProjectAndBranch (..))
 import qualified Unison.Server.CodebaseServer as Server
 import Unison.Symbol (Symbol)
 import qualified Unison.Syntax.Parser as Parser
@@ -54,7 +54,6 @@ import qualified Unison.Util.Pretty as P
 import qualified Unison.Util.TQueue as Q
 import qualified UnliftIO
 import UnliftIO.STM
-import Witch.Utility (unsafeInto)
 
 getUserInput ::
   forall m v a.
@@ -87,13 +86,7 @@ getUserInput codebase authHTTPClient getRoot currentPath numberedArgs =
             lift (Codebase.runTransaction codebase (Queries.loadProjectAndBranchNames projectId branchId)) <&> \case
               -- If the project branch has been deleted from sqlite, just show a borked prompt
               Nothing -> P.red "???"
-              Just (projectName, branchName) ->
-                P.purple $
-                  P.text $
-                    into @Text $
-                      These
-                        (unsafeInto @ProjectName projectName)
-                        (unsafeInto @ProjectBranchName branchName)
+              Just (projectName, branchName) -> P.purple (P.text (into @Text (These projectName branchName)))
       line <- Line.getInputLine (P.toANSI 80 (promptString <> fromString prompt))
       case line of
         Nothing -> pure QuitI

unison-cli/src/Unison/CommandLine/OutputMessages.hs

@@ -27,6 +27,7 @@ import Data.Time (UTCTime, getCurrentTime)
 import Data.Time.Format.Human (HumanTimeLocale (..), defaultHumanTimeLocale, humanReadableTimeI18N')
 import Data.Tuple (swap)
 import Data.Tuple.Extra (dupe)
+import Data.Void (absurd)
 import qualified Network.HTTP.Types as Http
 import Network.URI (URI)
 import qualified Network.URI.Encode as URI
@@ -314,9 +315,9 @@ notifyNumbered o = case o of
       then
         ( P.wrap $
             "Looks like there's no difference between "
-              <> prettyReadRemoteNamespace baseRepo
+              <> prettyReadRemoteNamespaceWith absurd baseRepo
               <> "and"
-              <> prettyReadRemoteNamespace headRepo
+              <> prettyReadRemoteNamespaceWith absurd headRepo
               <> ".",
           mempty
         )
@@ -331,8 +332,8 @@ notifyNumbered o = case o of
                   P.indentN 2 $
                     IP.makeExampleNoBackticks
                       IP.loadPullRequest
-                      [ prettyReadRemoteNamespace baseRepo,
-                        prettyReadRemoteNamespace headRepo
+                      [ prettyReadRemoteNamespaceWith absurd baseRepo,
+                        prettyReadRemoteNamespaceWith absurd headRepo
                       ],
                   "",
                   p
@@ -558,9 +559,14 @@ showListEdits patch ppe =
 prettyURI :: URI -> Pretty
 prettyURI = P.bold . P.blue . P.shown
 
-prettyReadRemoteNamespace :: ReadRemoteNamespace -> Pretty
+prettyReadRemoteNamespace :: ReadRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty
 prettyReadRemoteNamespace =
-  P.group . P.blue . P.text . RemoteRepo.printNamespace
+  prettyReadRemoteNamespaceWith \(ProjectAndBranch projectName branchName) ->
+    into @Text (These projectName branchName)
+
+prettyReadRemoteNamespaceWith :: (a -> Text) -> ReadRemoteNamespace a -> Pretty
+prettyReadRemoteNamespaceWith printProject =
+  P.group . P.blue . P.text . RemoteRepo.printNamespace printProject
 
 prettyWriteRemotePath :: WriteRemotePath -> Pretty
 prettyWriteRemotePath =
@@ -653,8 +659,8 @@ notifyUser dir = \case
   LoadPullRequest baseNS headNS basePath headPath mergedPath squashedPath ->
     pure $
       P.lines
-        [ P.wrap $ "I checked out" <> prettyReadRemoteNamespace baseNS <> "to" <> P.group (prettyPath' basePath <> "."),
-          P.wrap $ "I checked out" <> prettyReadRemoteNamespace headNS <> "to" <> P.group (prettyPath' headPath <> "."),
+        [ P.wrap $ "I checked out" <> prettyReadRemoteNamespaceWith absurd baseNS <> "to" <> P.group (prettyPath' basePath <> "."),
+          P.wrap $ "I checked out" <> prettyReadRemoteNamespaceWith absurd headNS <> "to" <> P.group (prettyPath' headPath <> "."),
           "",
           P.wrap $ "The merged result is in" <> P.group (prettyPath' mergedPath <> "."),
           P.wrap $ "The (squashed) merged result is in" <> P.group (prettyPath' squashedPath <> "."),
@@ -680,11 +686,11 @@ notifyUser dir = \case
             "Use"
               <> IP.makeExample
                 IP.push
-                [prettyReadRemoteNamespace baseNS, prettyPath' mergedPath]
+                [prettyReadRemoteNamespaceWith absurd baseNS, prettyPath' mergedPath]
               <> "or"
               <> IP.makeExample
                 IP.push
-                [prettyReadRemoteNamespace baseNS, prettyPath' squashedPath]
+                [prettyReadRemoteNamespaceWith absurd baseNS, prettyPath' squashedPath]
               <> "to push the changes."
         ]
   DisplayDefinitions output -> displayDefinitions output
@@ -1291,7 +1297,7 @@ notifyUser dir = \case
           "I just finished importing the branch"
             <> P.red (P.shown h)
             <> "from"
-            <> P.red (prettyReadRemoteNamespace (RemoteRepo.ReadRemoteNamespaceGit ns))
+            <> P.red (prettyReadRemoteNamespaceWith absurd (RemoteRepo.ReadRemoteNamespaceGit ns))
             <> "but now I can't find it."
       CouldntFindRemoteBranch repo path ->
         P.wrap $
@@ -1562,20 +1568,20 @@ notifyUser dir = \case
   PullAlreadyUpToDate ns dest ->
     pure . P.callout "😶" $
       P.wrap $
-        prettyPath' dest
+        prettyPullTarget dest
           <> "was already up-to-date with"
           <> P.group (prettyReadRemoteNamespace ns <> ".")
   PullSuccessful ns dest ->
     pure . P.okCallout $
       P.wrap $
         "Successfully updated"
-          <> prettyPath' dest
+          <> prettyPullTarget dest
           <> "from"
           <> P.group (prettyReadRemoteNamespace ns <> ".")
   MergeOverEmpty dest ->
     pure . P.okCallout $
       P.wrap $
-        "Successfully pulled into newly created namespace " <> P.group (prettyPath' dest <> ".")
+        "Successfully pulled into " <> P.group (prettyPullTarget dest <> ", which was empty.")
   MergeAlreadyUpToDate src dest ->
     pure . P.callout "😶" $
       P.wrap $
@@ -1717,7 +1723,7 @@ notifyUser dir = \case
       P.lines
         [ "Gist created. Pull via:",
           "",
-          P.indentN 2 (IP.patternName IP.pull <> " " <> prettyReadRemoteNamespace remoteNamespace)
+          P.indentN 2 (IP.patternName IP.pull <> " " <> prettyReadRemoteNamespaceWith absurd remoteNamespace)
         ]
   InitiateAuthFlow authURI -> do
     pure $
@@ -1779,8 +1785,9 @@ notifyUser dir = \case
           _ -> P.wrap $ P.text "It looks like someone modified" <> prettySharePath sharePath <> P.text "an instant before you. Pull and try again? 🤞"
       (Share.CheckAndSetPushErrorNoWritePermission sharePath) -> noWritePermission sharePath
       (Share.CheckAndSetPushErrorServerMissingDependencies hashes) -> missingDependencies hashes
-      (Share.CheckAndSetPushErrorInvalidRepoInfo repoInfo) -> invalidRepoInfo repoInfo
+      (Share.CheckAndSetPushErrorInvalidRepoInfo err repoInfo) -> invalidRepoInfo err repoInfo
       (Share.CheckAndSetPushErrorUserNotFound path) -> shareUserNotFound path
+      (Share.CheckAndSetPushErrorProjectNotFound projectShortHand) -> shareProjectNotFound projectShortHand
     ShareErrorFastForwardPush e -> case e of
       (Share.FastForwardPushErrorNoHistory sharePath) ->
         expectedNonEmptyPushDest (sharePathToWriteRemotePathShare sharePath)
@@ -1808,14 +1815,16 @@ notifyUser dir = \case
           pull = P.group . P.backticked . IP.patternName $ IP.pull
       (Share.FastForwardPushErrorNoWritePermission sharePath) -> noWritePermission sharePath
       (Share.FastForwardPushErrorServerMissingDependencies hashes) -> missingDependencies hashes
-      (Share.FastForwardPushErrorInvalidRepoInfo repoInfo) -> invalidRepoInfo repoInfo
+      (Share.FastForwardPushErrorInvalidRepoInfo err repoInfo) -> invalidRepoInfo err repoInfo
       (Share.FastForwardPushErrorUserNotFound path) -> shareUserNotFound path
+      (Share.FastForwardPushErrorProjectNotFound projectShortHand) -> shareProjectNotFound projectShortHand
     ShareErrorPull e -> case e of
       Share.PullErrorNoHistoryAtPath sharePath ->
         P.wrap $ P.text "The server didn't find anything at" <> prettySharePath sharePath
       Share.PullErrorNoReadPermission sharePath -> noReadPermission sharePath
-      Share.PullErrorInvalidRepoInfo repoInfo -> invalidRepoInfo repoInfo
+      Share.PullErrorInvalidRepoInfo err repoInfo -> invalidRepoInfo err repoInfo
       Share.PullErrorUserNotFound path -> shareUserNotFound path
+      Share.PullErrorProjectNotFound projectShortHand -> shareProjectNotFound projectShortHand
     ShareErrorGetCausalHashByPath err -> handleGetCausalHashByPathError err
     ShareErrorTransport te -> case te of
       DecodeFailure msg resp ->
@@ -1861,13 +1870,14 @@ notifyUser dir = \case
           . coerce @[Text] @[NameSegment]
           . toList
           . Share.pathSegments
-      invalidRepoInfo repoInfo =
+      invalidRepoInfo err repoInfo =
         P.lines
           [ P.wrap $
               "The server doesn't recognize the codebase path UCM provided. This is probably a bug in UCM.",
             P.text "",
             P.text "The invalid path is:\n"
-              <> P.indentN 2 (P.text (Share.unRepoInfo repoInfo))
+              <> P.indentN 2 (P.text (Share.unRepoInfo repoInfo)),
+            P.text err
           ]
       shareUserNotFound (Share.Path pathSegments) =
         P.lines
@@ -1876,6 +1886,11 @@ notifyUser dir = \case
             "",
             P.indentN 2 (P.text . Text.intercalate "." $ toList pathSegments)
           ]
+      shareProjectNotFound projectShortHand =
+        P.lines
+          [ P.wrap $
+              "This project does not exist: " <> P.text projectShortHand
+          ]
       missingDependencies hashes =
         -- maybe todo: stuff in all the args to CheckAndSetPush
         P.lines
@@ -1889,7 +1904,7 @@ notifyUser dir = \case
           ]
       handleGetCausalHashByPathError = \case
         Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermission sharePath
-        Share.GetCausalHashByPathErrorInvalidRepoInfo repoInfo -> invalidRepoInfo repoInfo
+        Share.GetCausalHashByPathErrorInvalidRepoInfo err repoInfo -> invalidRepoInfo err repoInfo
         Share.GetCausalHashByPathErrorUserNotFound path -> shareUserNotFound path
       noReadPermission sharePath =
         P.wrap $ P.text "The server said you don't have permission to read" <> P.group (prettySharePath sharePath <> ".")
@@ -2046,6 +2061,11 @@ prettyPath' p' =
     then "the current namespace"
     else P.blue (P.shown p')
 
+prettyPullTarget :: Input.PullTarget (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty
+prettyPullTarget = \case
+  Input.PullTargetLooseCode path -> prettyPath' path
+  Input.PullTargetProject project -> prettyProjectAndBranchName project
+
 prettyBranchId :: Input.AbsBranchId -> Pretty
 prettyBranchId = \case
   Left sch -> prettySCH sch

unison-cli/src/Unison/CommandLine/Welcome.hs

@@ -60,8 +60,7 @@ pullBase ns =
       abs = Path.Absolute {Path.unabsolute = rootPath}
       pullRemote =
         PullRemoteBranchI
-          (Just (ReadRemoteNamespaceShare ns))
-          (Path.Path' {Path.unPath' = Left abs})
+          (PullSourceTarget2 (ReadRemoteNamespaceShare ns) (PullTargetLooseCode (Path.Path' {Path.unPath' = Left abs})))
           SyncMode.Complete
           PullWithHistory
           Verbosity.Silent

unison-cli/src/Unison/LSP/FileAnalysis.hs

@@ -234,6 +234,8 @@ analyseNotes fileUri ppe src notes = do
               (_v, locs) <- toList defns
               (r, rs) <- withNeighbours (locs >>= aToR)
               pure (r, ("duplicate definition",) <$> rs)
+            TypeError.RedundantPattern loc -> singleRange loc
+            TypeError.UncoveredPatterns loc _pats -> singleRange loc
             -- These type errors don't have custom type error conversions, but some
             -- still have valid diagnostics.
             TypeError.Other e@(Context.ErrorNote {cause}) -> case cause of

unison-cli/src/Unison/Share/Sync.hs

@@ -125,7 +125,7 @@ checkAndSetPush unisonShareUrl path expectedHash causalHash uploadedCallback = d
     updatePath >>= \case
       Share.UpdatePathSuccess -> pure (Right ())
       Share.UpdatePathHashMismatch mismatch -> pure (Left (SyncError (CheckAndSetPushErrorHashMismatch mismatch)))
-      Share.UpdatePathInvalidRepoInfo repoInfo -> pure (Left (SyncError (CheckAndSetPushErrorInvalidRepoInfo repoInfo)))
+      Share.UpdatePathInvalidRepoInfo err repoInfo -> pure (Left (SyncError (CheckAndSetPushErrorInvalidRepoInfo err repoInfo)))
       Share.UpdatePathUserNotFound -> pure (Left (SyncError $ CheckAndSetPushErrorUserNotFound path))
       Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do
         -- Upload the causal and all of its dependencies.
@@ -133,7 +133,9 @@ checkAndSetPush unisonShareUrl path expectedHash causalHash uploadedCallback = d
           failed $
             err <&> \case
               UploadEntitiesNoWritePermission -> CheckAndSetPushErrorNoWritePermission path
-              UploadEntitiesInvalidRepoInfo repoInfo -> CheckAndSetPushErrorInvalidRepoInfo repoInfo
+              UploadEntitiesInvalidRepoInfo err repoInfo -> CheckAndSetPushErrorInvalidRepoInfo err repoInfo
+              UploadEntitiesUserNotFound _userHandle -> CheckAndSetPushErrorUserNotFound path
+              UploadEntitiesProjectNotFound projectShortHand -> CheckAndSetPushErrorProjectNotFound projectShortHand
 
         -- After uploading the causal and all of its dependencies, try setting the remote path again.
         updatePath >>= \case
@@ -147,7 +149,7 @@ checkAndSetPush unisonShareUrl path expectedHash causalHash uploadedCallback = d
           Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) ->
             failed (SyncError (CheckAndSetPushErrorServerMissingDependencies dependencies))
           Share.UpdatePathNoWritePermission _ -> failed (SyncError (CheckAndSetPushErrorNoWritePermission path))
-          Share.UpdatePathInvalidRepoInfo repoInfo -> failed (SyncError (CheckAndSetPushErrorInvalidRepoInfo repoInfo))
+          Share.UpdatePathInvalidRepoInfo err repoInfo -> failed (SyncError (CheckAndSetPushErrorInvalidRepoInfo err repoInfo))
           Share.UpdatePathUserNotFound -> failed (SyncError $ CheckAndSetPushErrorUserNotFound path)
       Share.UpdatePathNoWritePermission _ -> failed (SyncError (CheckAndSetPushErrorNoWritePermission path))
 
@@ -180,8 +182,8 @@ fastForwardPush unisonShareUrl path localHeadHash uploadedCallback = do
         Left (TransportError err) -> failed (TransportError err)
         Left (SyncError (GetCausalHashByPathErrorNoReadPermission _)) ->
           failed (SyncError (FastForwardPushErrorNoReadPermission path))
-        Left (SyncError (GetCausalHashByPathErrorInvalidRepoInfo repoInfo)) ->
-          failed (SyncError (FastForwardPushErrorInvalidRepoInfo repoInfo))
+        Left (SyncError (GetCausalHashByPathErrorInvalidRepoInfo err repoInfo)) ->
+          failed (SyncError (FastForwardPushErrorInvalidRepoInfo err repoInfo))
         Left (SyncError (GetCausalHashByPathErrorUserNotFound path)) ->
           failed (SyncError (FastForwardPushErrorUserNotFound path))
         Right Nothing -> failed (SyncError (FastForwardPushErrorNoHistory path))
@@ -214,7 +216,9 @@ fastForwardPush unisonShareUrl path localHeadHash uploadedCallback = do
             failed $
               err <&> \case
                 UploadEntitiesNoWritePermission -> (FastForwardPushErrorNoWritePermission path)
-                UploadEntitiesInvalidRepoInfo repoInfo -> FastForwardPushErrorInvalidRepoInfo repoInfo
+                UploadEntitiesInvalidRepoInfo err repoInfo -> FastForwardPushErrorInvalidRepoInfo err repoInfo
+                UploadEntitiesUserNotFound _userHandle -> FastForwardPushErrorUserNotFound path
+                UploadEntitiesProjectNotFound projectShortHand -> FastForwardPushErrorProjectNotFound projectShortHand
           where
             request =
               uploadEntities
@@ -261,7 +265,7 @@ fastForwardPush unisonShareUrl path localHeadHash uploadedCallback = do
       Share.FastForwardPathNotFastForward _ -> failed (SyncError (FastForwardPushErrorNotFastForward path))
       Share.FastForwardPathInvalidParentage (Share.InvalidParentage parent child) ->
         failed (SyncError (FastForwardPushInvalidParentage parent child))
-      Share.FastForwardPathInvalidRepoInfo repoInfo -> failed (SyncError (FastForwardPushErrorInvalidRepoInfo repoInfo))
+      Share.FastForwardPathInvalidRepoInfo err repoInfo -> failed (SyncError (FastForwardPushErrorInvalidRepoInfo err repoInfo))
       Share.FastForwardPathUserNotFound -> failed (SyncError (FastForwardPushErrorUserNotFound path))
 
 -- Return a list (in oldest-to-newest order) of hashes along the causal spine that connects the given arguments,
@@ -418,13 +422,15 @@ pull unisonShareUrl repoPath downloadedCallback =
             Left do
               err <&> \case
                 Share.DownloadEntitiesNoReadPermission _ -> PullErrorNoReadPermission repoPath
-                Share.DownloadEntitiesInvalidRepoInfo repoInfo -> PullErrorInvalidRepoInfo repoInfo
+                Share.DownloadEntitiesInvalidRepoInfo err repoInfo -> PullErrorInvalidRepoInfo err repoInfo
+                Share.DownloadEntitiesUserNotFound _ -> PullErrorUserNotFound repoPath
+                Share.DownloadEntitiesProjectNotFound projectShortHand -> PullErrorProjectNotFound projectShortHand
         Right () -> pure (Right (hash32ToCausalHash (Share.hashJWTHash hashJwt)))
 
 getCausalHashByPathErrorToPullError :: GetCausalHashByPathError -> PullError
 getCausalHashByPathErrorToPullError = \case
   GetCausalHashByPathErrorNoReadPermission path -> PullErrorNoReadPermission path
-  GetCausalHashByPathErrorInvalidRepoInfo repoInfo -> PullErrorInvalidRepoInfo repoInfo
+  GetCausalHashByPathErrorInvalidRepoInfo err repoInfo -> PullErrorInvalidRepoInfo err repoInfo
   GetCausalHashByPathErrorUserNotFound path -> PullErrorUserNotFound path
 
 ------------------------------------------------------------------------------------------------------------------------
@@ -717,8 +723,8 @@ getCausalHashByPath unisonShareUrl repoPath = do
     Right (Share.GetCausalHashByPathSuccess maybeHashJwt) -> Right maybeHashJwt
     Right (Share.GetCausalHashByPathNoReadPermission _) ->
       Left (SyncError (GetCausalHashByPathErrorNoReadPermission repoPath))
-    Right (Share.GetCausalHashByPathInvalidRepoInfo repoInfo) ->
-      Left (SyncError (GetCausalHashByPathErrorInvalidRepoInfo repoInfo))
+    Right (Share.GetCausalHashByPathInvalidRepoInfo err repoInfo) ->
+      Left (SyncError (GetCausalHashByPathErrorInvalidRepoInfo err repoInfo))
     Right Share.GetCausalHashByPathUserNotFound ->
       Left (SyncError $ GetCausalHashByPathErrorUserNotFound repoPath)
 
@@ -733,7 +739,12 @@ data UploadDispatcherJob
 
 data UploadEntitiesError
   = UploadEntitiesNoWritePermission
-  | UploadEntitiesInvalidRepoInfo Share.RepoInfo
+  | -- | (msg, repoInfo)
+    UploadEntitiesInvalidRepoInfo Text Share.RepoInfo
+  | -- | (userHandle)
+    UploadEntitiesUserNotFound Text
+  | -- | (project shorthand)
+    UploadEntitiesProjectNotFound Text
   deriving stock (Show)
 
 -- | Upload a set of entities to Unison Share. If the server responds that it cannot yet store any hash(es) due to
@@ -859,7 +870,9 @@ uploadEntities unisonShareUrl repoInfo hashes0 uploadedCallback = do
           Right (Share.UploadEntitiesNoWritePermission _) -> Left (SyncError UploadEntitiesNoWritePermission)
           Right (Share.UploadEntitiesHashMismatchForEntity _) -> error "hash mismatch; fixme"
           Right Share.UploadEntitiesSuccess -> Right Set.empty
-          Right (Share.UploadEntitiesInvalidRepoInfo repoInfo) -> Left (SyncError (UploadEntitiesInvalidRepoInfo repoInfo))
+          Right (Share.UploadEntitiesInvalidRepoInfo err repoInfo) -> Left (SyncError (UploadEntitiesInvalidRepoInfo err repoInfo))
+          Right (Share.UploadEntitiesProjectNotFound projectShortHand) -> Left (SyncError $ UploadEntitiesProjectNotFound projectShortHand)
+          Right (Share.UploadEntitiesUserNotFound userHandle) -> Left (SyncError $ UploadEntitiesUserNotFound userHandle)
 
       case result of
         Left err -> void (atomically (tryPutTMVar workerFailedVar err))

unison-cli/src/Unison/Share/Sync/Types.hs

@@ -20,8 +20,12 @@ data CheckAndSetPushError
   = CheckAndSetPushErrorHashMismatch Share.HashMismatch
   | CheckAndSetPushErrorNoWritePermission Share.Path
   | CheckAndSetPushErrorServerMissingDependencies (NESet Hash32)
-  | CheckAndSetPushErrorInvalidRepoInfo Share.RepoInfo
-  | CheckAndSetPushErrorUserNotFound Share.Path
+  | -- | The repo info was invalid. (err, repoInfo)
+    CheckAndSetPushErrorInvalidRepoInfo Text Share.RepoInfo
+  | -- | The user was not found.
+    CheckAndSetPushErrorUserNotFound Share.Path
+  | --  | (projectShortHand)
+    CheckAndSetPushErrorProjectNotFound Text
   deriving (Show)
 
 -- | An error occurred while fast-forward pushing code to Unison Share.
@@ -33,24 +37,30 @@ data FastForwardPushError
   | FastForwardPushErrorServerMissingDependencies (NESet Hash32)
   | --                              Parent Child
     FastForwardPushInvalidParentage Hash32 Hash32
-  | FastForwardPushErrorInvalidRepoInfo Share.RepoInfo
+  | -- | The repo info was invalid. (err, repoInfo)
+    FastForwardPushErrorInvalidRepoInfo Text Share.RepoInfo
   | FastForwardPushErrorUserNotFound Share.Path
+  | --  | (projectShortHand)
+    FastForwardPushErrorProjectNotFound Text
   deriving (Show)
 
 -- | An error occurred while pulling code from Unison Share.
 data PullError
   = PullErrorNoHistoryAtPath Share.Path
   | PullErrorNoReadPermission Share.Path
-  | PullErrorInvalidRepoInfo Share.RepoInfo
+  | -- | The repo info was invalid. (err, repoInfo)
+    PullErrorInvalidRepoInfo Text Share.RepoInfo
   | PullErrorUserNotFound Share.Path
+  | -- | (projectShortHand)
+    PullErrorProjectNotFound Text
   deriving (Show)
 
 -- | An error occurred when getting causal hash by path.
 data GetCausalHashByPathError
   = -- | The user does not have permission to read this path.
     GetCausalHashByPathErrorNoReadPermission Share.Path
-  | -- | The repo info was invalid.
-    GetCausalHashByPathErrorInvalidRepoInfo Share.RepoInfo
+  | -- | The repo info was invalid. (err, repoInfo)
+    GetCausalHashByPathErrorInvalidRepoInfo Text Share.RepoInfo
   | -- | The user was not found.
     GetCausalHashByPathErrorUserNotFound Share.Path
   deriving (Show)

unison-cli/tests/Unison/Test/LSP.hs

@@ -11,10 +11,12 @@ import qualified Data.Text as Text
 import EasyTest
 import qualified System.IO.Temp as Temp
 import qualified Unison.ABT as ABT
+import Unison.Builtin.Decls (unitRef)
 import qualified Unison.Cli.TypeCheck as Typecheck
 import Unison.Codebase (Codebase)
 import qualified Unison.Codebase.Init as Codebase.Init
 import qualified Unison.Codebase.SqliteCodebase as SC
+import Unison.ConstructorReference (GConstructorReference (..))
 import qualified Unison.LSP.Queries as LSPQ
 import qualified Unison.Lexer.Pos as Lexer
 import Unison.Parser.Ann (Ann (..))
@@ -138,11 +140,11 @@ term = let
       ( "Test annotations within pattern binds",
         [here|
 term = let
-  (third, tr^ue) = (false, true)
+  (third, (^)) = (false, ())
   true
   |],
         True,
-        pat (Pattern.Boolean () True)
+        pat (Pattern.Constructor () (ConstructorReference unitRef 0) [])
       ),
       ( "Test annotations for types with arrows",
         [here|

unison-cli/unison-cli.cabal

@@ -42,6 +42,8 @@ library
       Unison.Codebase.Editor.AuthorInfo
       Unison.Codebase.Editor.HandleInput
       Unison.Codebase.Editor.HandleInput.AuthLogin
+      Unison.Codebase.Editor.HandleInput.CreatePullRequest
+      Unison.Codebase.Editor.HandleInput.LoadPullRequest
       Unison.Codebase.Editor.HandleInput.MetadataUtils
       Unison.Codebase.Editor.HandleInput.MoveBranch
       Unison.Codebase.Editor.HandleInput.NamespaceDependencies

unison-core/src/Unison/Project.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 -- | Projects.
 --
 -- The syntax-related parsing code (what makes a valid project name, etc) could conceivably be moved into a different
@@ -20,16 +22,10 @@ import qualified Text.Builder
 import qualified Text.Builder as Text (Builder)
 import qualified Text.Megaparsec as Megaparsec
 import qualified Text.Megaparsec.Char as Megaparsec
+import Unison.Core.Project (ProjectName(..), ProjectBranchName(..), ProjectAndBranch(..))
 import Unison.Prelude
 import Witch
 
--- | The name of a project.
---
--- Convert to and from text with the 'From' and 'TryFrom' instances.
-newtype ProjectName
-  = ProjectName Text
-  deriving stock (Eq, Ord, Show)
-
 instance From ProjectName Text
 
 instance TryFrom Text ProjectName where
@@ -40,7 +36,7 @@ projectNameParser :: Megaparsec.Parsec Void Text ProjectName
 projectNameParser = do
   userSlug <- userSlugParser <|> pure mempty
   projectSlug <- projectSlugParser
-  pure (ProjectName (Text.Builder.run (userSlug <> projectSlug)))
+  pure (UnsafeProjectName (Text.Builder.run (userSlug <> projectSlug)))
   where
     projectSlugParser :: Megaparsec.Parsec Void Text Text.Builder
     projectSlugParser = do
@@ -60,7 +56,7 @@ projectNameParser = do
 -- >>> projectNameUserSlug "lens"
 -- Nothing
 projectNameUserSlug :: ProjectName -> Maybe Text
-projectNameUserSlug (ProjectName projectName) =
+projectNameUserSlug (UnsafeProjectName projectName) =
   if Text.head projectName == '@'
     then Just (Text.takeWhile (/= '/') (Text.drop 1 projectName))
     else Nothing
@@ -76,10 +72,10 @@ projectNameUserSlug (ProjectName projectName) =
 -- >>> prependUserSlugToProjectName "???invalid???" "@unison/base"
 -- "@unison/base"
 prependUserSlugToProjectName :: Text -> ProjectName -> ProjectName
-prependUserSlugToProjectName userSlug (ProjectName projectName) =
+prependUserSlugToProjectName userSlug (UnsafeProjectName projectName) =
   if Text.head projectName == '@'
-    then ProjectName projectName
-    else fromMaybe (ProjectName projectName) (Megaparsec.parseMaybe projectNameParser newProjectName)
+    then UnsafeProjectName projectName
+    else fromMaybe (UnsafeProjectName projectName) (Megaparsec.parseMaybe projectNameParser newProjectName)
   where
     newProjectName =
       Text.Builder.run $
@@ -88,13 +84,6 @@ prependUserSlugToProjectName userSlug (ProjectName projectName) =
           <> Text.Builder.char '/'
           <> Text.Builder.text projectName
 
--- | The name of a branch of a project.
---
--- Convert to and from text with the 'From' and 'TryFrom' instances.
-newtype ProjectBranchName
-  = ProjectBranchName Text
-  deriving stock (Eq, Ord, Show)
-
 instance From ProjectBranchName Text
 
 instance TryFrom Text ProjectBranchName where
@@ -153,13 +142,6 @@ prependUserSlugToProjectBranchName userSlug (ProjectBranchName branchName) =
           <> Text.Builder.char '/'
           <> Text.Builder.text branchName
 
--- | A generic data structure that contains information about a project and a branch in that project.
-data ProjectAndBranch a b = ProjectAndBranch
-  { project :: a,
-    branch :: b
-  }
-  deriving stock (Eq, Generic, Show)
-
 -- | @project/branch@ syntax for project+branch pair, with up to one
 -- side optional. Missing value means "the current one".
 instance From (These ProjectName ProjectBranchName) Text where

unison-share-api/src/Unison/Server/CodebaseServer.hs

@@ -277,7 +277,7 @@ startServer env opts rt codebase onStart = do
   token <- case token opts of
     Just t -> return $ C8.pack t
     _ -> genToken
-  let baseUrl = BaseUrl "http://127.0.0.1" token
+  let baseUrl = BaseUrl (fromMaybe "http://127.0.0.1" (host opts)) token
   let settings =
         defaultSettings
           & maybe id setPort (port opts)

unison-share-api/src/Unison/Sync/Types.hs

@@ -531,7 +531,7 @@ data GetCausalHashByPathResponse
   = GetCausalHashByPathSuccess (Maybe HashJWT)
   | GetCausalHashByPathNoReadPermission Path
   | GetCausalHashByPathUserNotFound
-  | GetCausalHashByPathInvalidRepoInfo RepoInfo
+  | GetCausalHashByPathInvalidRepoInfo Text RepoInfo
   deriving stock (Show, Eq, Ord)
 
 instance ToJSON GetCausalHashByPathResponse where
@@ -539,7 +539,7 @@ instance ToJSON GetCausalHashByPathResponse where
     GetCausalHashByPathSuccess hashJWT -> jsonUnion "success" hashJWT
     GetCausalHashByPathNoReadPermission path -> jsonUnion "no_read_permission" path
     GetCausalHashByPathUserNotFound -> jsonUnion "user_not_found" ()
-    GetCausalHashByPathInvalidRepoInfo repoInfo -> jsonUnion "invalid_repo_info" repoInfo
+    GetCausalHashByPathInvalidRepoInfo msg repoInfo -> jsonUnion "invalid_repo_info" (msg, repoInfo)
 
 instance FromJSON GetCausalHashByPathResponse where
   parseJSON = Aeson.withObject "GetCausalHashByPathResponse" \obj -> do
@@ -547,7 +547,7 @@ instance FromJSON GetCausalHashByPathResponse where
       "success" -> GetCausalHashByPathSuccess <$> obj .: "payload"
       "no_read_permission" -> GetCausalHashByPathNoReadPermission <$> obj .: "payload"
       "user_not_found" -> pure GetCausalHashByPathUserNotFound
-      "invalid_repo_info" -> GetCausalHashByPathInvalidRepoInfo <$> obj .: "payload"
+      "invalid_repo_info" -> uncurry GetCausalHashByPathInvalidRepoInfo <$> obj .: "payload"
       t -> failText $ "Unexpected GetCausalHashByPathResponse type: " <> t
 
 ------------------------------------------------------------------------------------------------------------------------
@@ -582,7 +582,12 @@ data DownloadEntitiesResponse
 
 data DownloadEntitiesError
   = DownloadEntitiesNoReadPermission RepoInfo
-  | DownloadEntitiesInvalidRepoInfo RepoInfo
+  | -- | (msg, repoInfo)
+    DownloadEntitiesInvalidRepoInfo Text RepoInfo
+  | -- | (userHandle)
+    DownloadEntitiesUserNotFound Text
+  | -- | (project shorthand)
+    DownloadEntitiesProjectNotFound Text
   deriving stock (Eq, Show)
 
 -- data DownloadEntities = DownloadEntities
@@ -594,14 +599,18 @@ instance ToJSON DownloadEntitiesResponse where
   toJSON = \case
     DownloadEntitiesSuccess entities -> jsonUnion "success" entities
     DownloadEntitiesFailure (DownloadEntitiesNoReadPermission repoInfo) -> jsonUnion "no_read_permission" repoInfo
-    DownloadEntitiesFailure (DownloadEntitiesInvalidRepoInfo repoInfo) -> jsonUnion "invalid_repo_info" repoInfo
+    DownloadEntitiesFailure (DownloadEntitiesInvalidRepoInfo msg repoInfo) -> jsonUnion "invalid_repo_info" (msg, repoInfo)
+    DownloadEntitiesFailure (DownloadEntitiesUserNotFound userHandle) -> jsonUnion "user_not_found" userHandle
+    DownloadEntitiesFailure (DownloadEntitiesProjectNotFound projectShorthand) -> jsonUnion "project_not_found" projectShorthand
 
 instance FromJSON DownloadEntitiesResponse where
   parseJSON = Aeson.withObject "DownloadEntitiesResponse" \obj ->
     obj .: "type" >>= Aeson.withText "type" \case
       "success" -> DownloadEntitiesSuccess <$> obj .: "payload"
       "no_read_permission" -> DownloadEntitiesFailure . DownloadEntitiesNoReadPermission <$> obj .: "payload"
-      "invalid_repo_info" -> DownloadEntitiesFailure . DownloadEntitiesInvalidRepoInfo <$> obj .: "payload"
+      "invalid_repo_info" -> DownloadEntitiesFailure . uncurry DownloadEntitiesInvalidRepoInfo <$> obj .: "payload"
+      "user_not_found" -> DownloadEntitiesFailure . DownloadEntitiesUserNotFound <$> obj .: "payload"
+      "project_not_found" -> DownloadEntitiesFailure . DownloadEntitiesProjectNotFound <$> obj .: "payload"
       t -> failText $ "Unexpected DownloadEntitiesResponse type: " <> t
 
 -- instance ToJSON DownloadEntities where
@@ -645,7 +654,12 @@ data UploadEntitiesResponse
   | UploadEntitiesNeedDependencies (NeedDependencies Hash32)
   | UploadEntitiesNoWritePermission RepoInfo
   | UploadEntitiesHashMismatchForEntity HashMismatchForEntity
-  | UploadEntitiesInvalidRepoInfo RepoInfo
+  | -- | (msg, repoInfo)
+    UploadEntitiesInvalidRepoInfo Text RepoInfo
+  | -- | (userHandle)
+    UploadEntitiesUserNotFound Text
+  | -- | (project shorthand)
+    UploadEntitiesProjectNotFound Text
   deriving stock (Show, Eq, Ord)
 
 data HashMismatchForEntity = HashMismatchForEntity {supplied :: Hash32, computed :: Hash32}
@@ -657,7 +671,9 @@ instance ToJSON UploadEntitiesResponse where
     UploadEntitiesNeedDependencies nd -> jsonUnion "need_dependencies" nd
     UploadEntitiesNoWritePermission repoInfo -> jsonUnion "no_write_permission" repoInfo
     UploadEntitiesHashMismatchForEntity mismatch -> jsonUnion "hash_mismatch_for_entity" mismatch
-    UploadEntitiesInvalidRepoInfo repoInfo -> jsonUnion "invalid_repo_info" repoInfo
+    UploadEntitiesInvalidRepoInfo msg repoInfo -> jsonUnion "invalid_repo_info" (msg, repoInfo)
+    UploadEntitiesUserNotFound userHandle -> jsonUnion "user_not_found" userHandle
+    UploadEntitiesProjectNotFound projectShorthand -> jsonUnion "project_not_found" projectShorthand
 
 instance FromJSON UploadEntitiesResponse where
   parseJSON = Aeson.withObject "UploadEntitiesResponse" \obj ->
@@ -666,7 +682,9 @@ instance FromJSON UploadEntitiesResponse where
       "need_dependencies" -> UploadEntitiesNeedDependencies <$> obj .: "payload"
       "no_write_permission" -> UploadEntitiesNoWritePermission <$> obj .: "payload"
       "hash_mismatch_for_entity" -> UploadEntitiesHashMismatchForEntity <$> obj .: "payload"
-      "invalid_repo_info" -> UploadEntitiesInvalidRepoInfo <$> obj .: "payload"
+      "invalid_repo_info" -> uncurry UploadEntitiesInvalidRepoInfo <$> obj .: "payload"
+      "user_not_found" -> UploadEntitiesUserNotFound <$> obj .: "payload"
+      "project_not_found" -> UploadEntitiesProjectNotFound <$> obj .: "payload"
       t -> failText $ "Unexpected UploadEntitiesResponse type: " <> t
 
 instance ToJSON HashMismatchForEntity where
@@ -739,7 +757,7 @@ data FastForwardPathResponse
     FastForwardPathNoHistory
   | -- | This wasn't a fast-forward. You said the first hash was a parent of the second hash, but I disagree.
     FastForwardPathInvalidParentage InvalidParentage
-  | FastForwardPathInvalidRepoInfo RepoInfo
+  | FastForwardPathInvalidRepoInfo Text RepoInfo
   | FastForwardPathUserNotFound
   deriving stock (Show)
 
@@ -754,7 +772,7 @@ instance ToJSON FastForwardPathResponse where
     FastForwardPathNotFastForward hashJwt -> jsonUnion "not_fast_forward" hashJwt
     FastForwardPathNoHistory -> jsonUnion "no_history" (Object mempty)
     FastForwardPathInvalidParentage invalidParentage -> jsonUnion "invalid_parentage" invalidParentage
-    FastForwardPathInvalidRepoInfo repoInfo -> jsonUnion "invalid_repo_info" repoInfo
+    FastForwardPathInvalidRepoInfo msg repoInfo -> jsonUnion "invalid_repo_info" (msg, repoInfo)
     FastForwardPathUserNotFound -> jsonUnion "user_not_found" (Object mempty)
 
 instance FromJSON FastForwardPathResponse where
@@ -767,7 +785,7 @@ instance FromJSON FastForwardPathResponse where
         "not_fast_forward" -> FastForwardPathNotFastForward <$> o .: "payload"
         "no_history" -> pure FastForwardPathNoHistory
         "invalid_parentage" -> FastForwardPathInvalidParentage <$> o .: "payload"
-        "invalid_repo_info" -> FastForwardPathInvalidRepoInfo <$> o .: "payload"
+        "invalid_repo_info" -> uncurry FastForwardPathInvalidRepoInfo <$> o .: "payload"
         "user_not_found" -> pure FastForwardPathUserNotFound
         t -> failText $ "Unexpected FastForwardPathResponse type: " <> t
 
@@ -808,7 +826,8 @@ data UpdatePathResponse
   | UpdatePathHashMismatch HashMismatch
   | UpdatePathMissingDependencies (NeedDependencies Hash32)
   | UpdatePathNoWritePermission Path
-  | UpdatePathInvalidRepoInfo RepoInfo
+  | -- | (errMsg, repoInfo)
+    UpdatePathInvalidRepoInfo Text RepoInfo
   | UpdatePathUserNotFound
   deriving stock (Show, Eq, Ord)
 
@@ -818,7 +837,7 @@ instance ToJSON UpdatePathResponse where
     UpdatePathHashMismatch hm -> jsonUnion "hash_mismatch" hm
     UpdatePathMissingDependencies md -> jsonUnion "missing_dependencies" md
     UpdatePathNoWritePermission path -> jsonUnion "no_write_permission" path
-    UpdatePathInvalidRepoInfo repoInfo -> jsonUnion "invalid_repo_info" repoInfo
+    UpdatePathInvalidRepoInfo errMsg repoInfo -> jsonUnion "invalid_repo_info" (errMsg, repoInfo)
     UpdatePathUserNotFound -> jsonUnion "user_not_found" (Object mempty)
 
 instance FromJSON UpdatePathResponse where
@@ -829,7 +848,7 @@ instance FromJSON UpdatePathResponse where
         "hash_mismatch" -> UpdatePathHashMismatch <$> obj .: "payload"
         "missing_dependencies" -> UpdatePathMissingDependencies <$> obj .: "payload"
         "no_write_permission" -> UpdatePathNoWritePermission <$> obj .: "payload"
-        "invalid_repo_info" -> UpdatePathInvalidRepoInfo <$> obj .: "payload"
+        "invalid_repo_info" -> uncurry UpdatePathInvalidRepoInfo <$> obj .: "payload"
         "user_not_found" -> pure UpdatePathUserNotFound
         t -> failText $ "Unexpected UpdatePathResponse type: " <> t
 

unison-share-projects-api/src/Unison/Share/API/Projects.hs

@@ -281,10 +281,10 @@ instance ToJSON SetProjectBranchHeadRequest where
 data SetProjectBranchHeadResponse
   = SetProjectBranchHeadResponseUnauthorized Unauthorized
   | SetProjectBranchHeadResponseNotFound NotFound
-  | SetProjectBranchHeadResponseSuccess
   | SetProjectBranchHeadResponseMissingCausalHash !Hash32
   | -- | (expected, actual)
     SetProjectBranchHeadResponseExpectedCausalHashMismatch !Hash32 !Hash32
+  | SetProjectBranchHeadResponseSuccess
   deriving stock (Eq, Show, Generic)
 
 instance FromJSON SetProjectBranchHeadResponse where

unison-src/builtin-tests/tests.u

@@ -1,10 +1,58 @@
 
+shouldFail fn = isLeft <| catchAll fn
+
 tests : '{IO,Exception} ()
 tests = Tests.main do
   !crypto.hash.tests
   !hmac.tests
   !concurrency.tests
-  check "bug is caught" do isLeft (catchAll do bug ())
+  !tcp.tests
+  check "bug is caught" do shouldFail do bug ()
+
+tcp.tests = do
+  check "connects to example.com" do
+    socket = Socket.client (HostName "example.com") (Port "80")
+    Socket.send socket (toUtf8 "GET /index.html HTTP/1.0\r\n\r\n")
+    response = Socket.receive socket
+    Socket.close socket
+    contains "HTTP/1.0 200 OK" (base.Text.fromUtf8 response)
+  check "rejects invalid port" do shouldFail do Socket.client (HostName "example.com") (Port "what")
+  check "no send after close" do shouldFail do
+    socket = Socket.client (HostName "example.com") (Port "80")
+    Socket.close socket
+    Socket.send socket (toUtf8 "GET /index.html HTTP/1.0\r\n\r\n")
+  check "no send on listener" do shouldFail do
+    match Socket.server None (Port "0") with
+        BoundServerSocket socket -> Socket.send socket (toUtf8 "what")
+
+
+  setup = catchAll do
+      socket = Socket.listen (server None (Port "0"))
+      port = match socket with
+          ListeningServerSocket sock -> Socket.port sock
+      (socket, port)
+
+  match setup with
+      Left exn ->
+        Debug.trace "Setup failed" exn
+        Tests.fail "Unable to bind and listen on a socket" ""
+      Right (socket, port) ->
+          serve = do
+              sock = Socket.accept socket
+              data = Socket.receive sock
+              Socket.send sock (toUtf8 "from server")
+              base.Text.fromUtf8 data
+
+          serveResult = !Promise.new
+          _ = fork do Promise.write serveResult (catchAll serve)
+
+          data = catchAll do
+              clientSocket = Socket.client (HostName "localhost") (Port (Nat.toText port))
+              Socket.send clientSocket (toUtf8 "from client")
+              base.Text.fromUtf8 (Socket.receive clientSocket)
+
+          checkEqual "Server received data" (Promise.read serveResult) (Right "from client")
+          checkEqual "Client received data" data (Right "from server")
 
 crypto.hash.tests = do
   hash alg = hashBytes alg (toUtf8 "")

unison-src/tests/caseguard.u

@@ -10,6 +10,6 @@ use Universal ==
 
 f = cases
   x | x == "woot" -> false
-  y | y == "foo" -> true
+  y | otherwise -> true
 
 -- > f "woot"

unison-src/tests/imports.u

@@ -19,4 +19,4 @@ use Nat drop
 
 > match Some (100 + 200 / 3 * 2) with
     Optional.None -> 19
-    Some 200 -> 20
+    Some _ -> 20

unison-src/tests/inner-lambda1.u

@@ -12,4 +12,5 @@ search hit bot top =
         +0 -> Some mid
         -1 -> go bot (drop mid 1)
         +1 -> go (mid + 1) top
+        _ -> bug "unexpected"
   go bot top

unison-src/tests/inner-lambda2.u

@@ -13,4 +13,5 @@ search hit bot top =
         +0 -> Some mid
         -1 -> go bot (drop mid 1)
         +1 -> go (mid + 1) top
+        _ -> bug "unexpected"
   go bot top

unison-src/tests/methodical/pattern-matching.u

@@ -17,7 +17,7 @@ pat6 x y = cases (p1, _) -> (x + y : Nat, p1)
 
 pat7 x y = cases
   (p1, _) | p1 == 9 -> (x + y : Nat, p1)
-  (p1, _) | true    -> (0, p1)
+  (p1, _) | otherwise    -> (0, p1)
 
 bpat = cases
   false -> 0

unison-src/tests/parenthesized-blocks.u

@@ -1,5 +1,5 @@
 
 x = (if true then 1 else 0) + 1
-y = (match 1 with 1 -> 1) + 1
+y = (match 1 with _ -> 1) + 1
 
 > (x, y)

unison-src/tests/pattern-match-seq.u

@@ -11,12 +11,12 @@ lenLit = cases
   [_] -> 1
   [_, _] -> 2
   [_, _, _] -> 3
+  _ -> bug "unexpected"
 
 lenCons : [a] -> Nat
 lenCons = cases
   [] -> 0
   _ +: t -> 1 + lenCons t
-  _ +: (_ +: t) -> 2 + lenCons t
 
 lenSnoc : [a] -> Nat
 lenSnoc = cases

unison-src/tests/pattern-matching.u

@@ -16,8 +16,8 @@ y = match Foo1 1 with
   Foo1 _ -> 10
 
 z = match Foo2 1 "hi" with
-  Foo2 x _ -> x
   Foo2 1 _ -> 1
+  Foo2 x _ -> x
 
 w = match Foo3.Foo3 1 2 "bye" with
   Foo3.Foo3 1 2 x -> x Text.++ "bye"
@@ -26,7 +26,6 @@ w = match Foo3.Foo3 1 2 "bye" with
 w2 = cases
   Foo3.Foo3 1 4 x -> x Text.++ "bye"
   Foo3.Foo3 x y z -> z Text.++ z
-  _ -> "hi"
 
 len : List a -> Nat
 len = cases

unison-src/tests/pattern-matching2.u

@@ -15,7 +15,8 @@ y = match Foo1 1 with
   Foo1 _ -> 10
 
 z = match Foo2 1 "hi" with
-  Foo2 x "bye" -> x
   Foo2 1 "hi" -> 1
+  Foo2 x "bye" -> x
+  _ -> bug "unexpected"
 
 > z

unison-src/tests/r2.u

@@ -3,4 +3,5 @@ r2 : Nat
 r2 = match Optional.Some true with
   Optional.Some true -> 1
   Optional.Some false -> 0
+  Optional.None -> bug "unexpected"
 

unison-src/tests/r3.u

@@ -2,5 +2,6 @@ r3 : Nat
 r3 = match Optional.Some true with
   Optional.Some true -> 1
   Optional.Some false -> 0
+  Optional.None -> bug "unexpected"
 
 

unison-src/tests/r4x.u

@@ -1,3 +1,4 @@
 r4 : Int -> Int
 r4 = cases
   +1 -> +1
+  x -> x

unison-src/tests/sequence-at-0.u

@@ -1,2 +1,3 @@
 > match at 0 [100] with
   Optional.Some _ -> "Hooray!"
+  Optional.None -> bug "unexpected"