Parameterize Split

lib/unison-util-recursion/package.yaml

@@ -6,6 +6,7 @@ ghc-options: -Wall
 
 dependencies:
   - base
+  - containers
   - free
 
 library:

lib/unison-util-recursion/src/Unison/Util/Recursion.hs

@@ -8,6 +8,7 @@ module Unison.Util.Recursion
     cataM,
     para,
     Fix (..),
+    XNor (..),
   )
 where
 
@@ -16,6 +17,7 @@ import Control.Comonad.Cofree (Cofree ((:<)))
 import Control.Comonad.Trans.Cofree (CofreeF)
 import Control.Comonad.Trans.Cofree qualified as CofreeF
 import Control.Monad ((<=<))
+import Data.Sequence (Seq (Empty, (:<|)))
 
 type Algebra f a = f a -> a
 
@@ -53,3 +55,26 @@ instance (Functor f) => Recursive (Fix f) f where
 instance (Functor f) => Recursive (Cofree f a) (CofreeF f a) where
   embed (a CofreeF.:< fco) = a :< fco
   project (a :< fco) = a CofreeF.:< fco
+
+-- | The pattern functor for sequences.
+data XNor a b = Neither | Both a !b
+
+instance Functor (XNor a) where
+  fmap fn = \case
+    Neither -> Neither
+    Both a b -> Both a $ fn b
+
+-- |
+--
+--  __NB__: Lists are lazy, so this instance is technically partial.
+instance Recursive [a] (XNor a) where
+  cata φ = foldr (\a -> φ . Both a) $ φ Neither
+  embed = \case
+    Neither -> []
+    Both a b -> a : b
+
+instance Recursive (Seq a) (XNor a) where
+  cata φ = foldr (\a -> φ . Both a) $ φ Neither
+  embed = \case
+    Neither -> Empty
+    Both a b -> a :<| b

lib/unison-util-recursion/unison-util-recursion.cabal

@@ -53,5 +53,6 @@ library
   ghc-options: -Wall
   build-depends:
       base
+    , containers
     , free
   default-language: Haskell2010

parser-typechecker/src/U/Codebase/Projects.hs

@@ -4,6 +4,7 @@ module U.Codebase.Projects
 where
 
 import Control.Lens (ifoldMap)
+import Data.Bool (bool)
 import Data.Map qualified as Map
 import U.Codebase.Branch
 import U.Codebase.Branch qualified as Branch
@@ -24,29 +25,24 @@ import Unison.Util.Monoid (ifoldMapM)
 -- For the top-level name lookup of a user codebase it returns the project roots, and will return something like:
 -- @[(public.nested.myproject.latest, #abc), (public.other.namespace.otherproject.main, #def)]@
 inferDependencyMounts :: Branch Sqlite.Transaction -> Sqlite.Transaction [(Path, BranchHash)]
-inferDependencyMounts branch = do
-  children <- Branch.nonEmptyChildren branch
-  do
-    children
-    & ifoldMapM \segment child -> do
-      case segment of
-        seg
-          | seg == libSegment -> do
-              childBranch <- Causal.value child
-              deps <- Branch.nonEmptyChildren childBranch
-              deps
-                & ( ifoldMap \depName depBranch ->
-                      [(Path.fromList [seg, depName], Causal.valueHash depBranch)]
-                  )
-                & pure
-          | otherwise -> do
-              childBranch <- Causal.value child
-              nestedChildren <- Branch.nonEmptyChildren childBranch
-              -- If a given child has a lib child, then it's inferred to be a project root.
-              -- This allows us to detect most project roots in loose code.
-              -- Note, we only do this on children nested at least one level deep
-              -- to avoid treating project roots as their own self-referential dependency
-              -- mounts. Mount paths must not be empty.
-              case Map.member libSegment nestedChildren of
-                True -> pure [(Path.fromList [seg], Causal.valueHash child)]
-                False -> inferDependencyMounts childBranch <&> map (first (Path.cons seg))
+inferDependencyMounts =
+  ifoldMapM
+    ( \seg child -> do
+        childBranch <- Causal.value child
+        if seg == libSegment
+          then
+            ifoldMap (\depName depBranch -> [(Path.fromList [seg, depName], Causal.valueHash depBranch)])
+              <$> Branch.nonEmptyChildren childBranch
+          else -- If a given child has a lib child, then it's inferred to be a project root.
+          -- This allows us to detect most project roots in loose code.
+          -- Note, we only do this on children nested at least one level deep
+          -- to avoid treating project roots as their own self-referential dependency
+          -- mounts. Mount paths must not be empty.
+
+            bool
+              (map (first . Path.resolve $ Path.singleton seg) <$> inferDependencyMounts childBranch)
+              (pure [(Path.singleton seg, Causal.valueHash child)])
+              . Map.member libSegment
+              =<< Branch.nonEmptyChildren childBranch
+    )
+    <=< Branch.nonEmptyChildren

parser-typechecker/src/Unison/Codebase.hs

@@ -157,6 +157,7 @@ import Unison.Typechecker.TypeLookup (TypeLookup (TypeLookup))
 import Unison.Typechecker.TypeLookup qualified as TL
 import Unison.UnisonFile qualified as UF
 import Unison.Util.Defns (Defns (..), DefnsF)
+import Unison.Util.Recursion (XNor (Both, Neither), cata)
 import Unison.Util.Relation qualified as Rel
 import Unison.Var (Var)
 import Unison.WatchKind qualified as WK
@@ -189,14 +190,9 @@ getShallowCausalAtPath ::
   Path ->
   (V2Branch.CausalBranch Sqlite.Transaction) ->
   Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
-getShallowCausalAtPath path causal = do
-  case path of
-    Path.Empty -> pure causal
-    ns Path.:< p -> do
-      b <- V2Causal.value causal
-      case V2Branch.childAt ns b of
-        Nothing -> pure (Cv.causalbranch1to2 Branch.empty)
-        Just childCausal -> getShallowCausalAtPath p childCausal
+getShallowCausalAtPath = cata \case
+  Neither -> pure
+  Both ns fn -> maybe (pure $ Cv.causalbranch1to2 Branch.empty) fn . V2Branch.childAt ns <=< V2Causal.value
 
 -- | Recursively descend into causals following the given path,
 -- Use the root causal if none is provided.
@@ -212,15 +208,9 @@ getMaybeShallowBranchAtPath ::
   Path ->
   V2Branch.Branch Sqlite.Transaction ->
   Sqlite.Transaction (Maybe (V2Branch.Branch Sqlite.Transaction))
-getMaybeShallowBranchAtPath path branch = do
-  case path of
-    Path.Empty -> pure $ Just branch
-    ns Path.:< p -> do
-      case V2Branch.childAt ns branch of
-        Nothing -> pure Nothing
-        Just childCausal -> do
-          childBranch <- V2Causal.value childCausal
-          getMaybeShallowBranchAtPath p childBranch
+getMaybeShallowBranchAtPath = cata \case
+  Neither -> pure . Just
+  Both ns fn -> maybe (pure Nothing) (fn <=< V2Causal.value) . V2Branch.childAt ns
 
 -- | Recursively descend into causals following the given path,
 -- Use the root causal if none is provided.

parser-typechecker/src/Unison/Codebase/Branch.hs

@@ -38,7 +38,6 @@ module Unison.Codebase.Branch
     children,
     nonEmptyChildren,
     deepEdits',
-    toList0,
     namespaceStats,
 
     -- * step
@@ -131,8 +130,7 @@ import Unison.Codebase.Causal (Causal)
 import Unison.Codebase.Causal qualified as Causal
 import Unison.Codebase.Patch (Patch)
 import Unison.Codebase.Patch qualified as Patch
-import Unison.Codebase.Path (Path (..))
-import Unison.Codebase.Path qualified as Path
+import Unison.Codebase.Path (Path)
 import Unison.Hashing.V2 qualified as Hashing (ContentAddressable (contentHash))
 import Unison.Hashing.V2.Convert qualified as H
 import Unison.Name (Name)
@@ -145,6 +143,7 @@ import Unison.Reference qualified as Reference
 import Unison.Referent (Referent)
 import Unison.Referent qualified as Referent
 import Unison.Util.List qualified as List
+import Unison.Util.Recursion (XNor (Both, Neither), cata, project)
 import Unison.Util.Relation qualified as R
 import Unison.Util.Relation qualified as Relation
 import Unison.Util.Set qualified as Set
@@ -254,42 +253,23 @@ discardHistory :: (Applicative m) => Branch m -> Branch m
 discardHistory b =
   one (discardHistory0 (head b))
 
--- `before b1 b2` is true if `b2` incorporates all of `b1`
+-- | `before b1 b2` is true if `b2` incorporates all of `b1`
 before :: (Monad m) => Branch m -> Branch m -> m Bool
 before (Branch b1) (Branch b2) = Causal.before b1 b2
 
--- | what does this do? —AI
-toList0 :: Branch0 m -> [(Path, Branch0 m)]
-toList0 = go Path.empty
-  where
-    go p b =
-      (p, b)
-        : ( Map.toList (b ^. children)
-              >>= ( \(seg, cb) ->
-                      go (Path.snoc p seg) (head cb)
-                  )
-          )
-
 -- returns `Nothing` if no Branch at `path` or if Branch is empty at `path`
-getAt ::
-  Path ->
-  Branch m ->
-  Maybe (Branch m)
-getAt path root = case Path.uncons path of
-  Nothing -> if isEmpty root then Nothing else Just root
-  Just (seg, path) -> case Map.lookup seg (head root ^. children) of
-    Just b -> getAt path b
-    Nothing -> Nothing
+getAt :: Path -> Branch m -> Maybe (Branch m)
+getAt = cata \case
+  Neither -> \root -> if isEmpty root then Nothing else Just root
+  Both seg fn -> fn <=< Map.lookup seg . view children . head
 
 getAt' :: Path -> Branch m -> Branch m
 getAt' p b = fromMaybe empty $ getAt p b
 
 getAt0 :: Path -> Branch0 m -> Branch0 m
-getAt0 p b = case Path.uncons p of
-  Nothing -> b
-  Just (seg, path) -> case Map.lookup seg (b ^. children) of
-    Just c -> getAt0 path (head c)
-    Nothing -> empty0
+getAt0 = cata \case
+  Neither -> id
+  Both seg fn -> fn . maybe empty0 head . Map.lookup seg . view children
 
 empty :: Branch m
 empty = Branch $ Causal.one empty0
@@ -458,12 +438,11 @@ modifyAtM ::
   (Branch m -> n (Branch m)) ->
   Branch m ->
   n (Branch m)
-modifyAtM path f b = case Path.uncons path of
-  Nothing -> f b
-  Just (seg, path) ->
-    let child = getChildBranch seg (head b)
-     in -- step the branch by updating its children according to fixup
-        (\child' -> step (setChildBranch seg child') b) <$> modifyAtM path f child
+modifyAtM path f = flip cata path \case
+  Neither -> f
+  Both seg fn -> \b ->
+    -- step the branch by updating its children according to fixup
+    flip step b . setChildBranch seg <$> fn (getChildBranch seg $ head b)
 
 -- | Perform updates over many locations within a branch by batching up operations on
 -- sub-branches as much as possible without affecting semantics.
@@ -536,12 +515,11 @@ batchUpdatesM (toList -> actions) curBranch = foldM execActions curBranch (group
     -- The order within a given key is stable.
     groupByNextSegment :: [(Path, x)] -> Map NameSegment [(Path, x)]
     groupByNextSegment =
-      Map.unionsWith (<>) . fmap \case
-        (seg :< rest, action) -> Map.singleton seg [(rest, action)]
-        _ -> error "groupByNextSegment called on current path, which shouldn't happen."
+      Map.unionsWith (<>) . fmap \(p, action) -> case project p of
+        Neither -> error "groupByNextSegment called on current path, which shouldn't happen."
+        Both seg rest -> Map.singleton seg [(rest, action)]
     pathLocation :: Path -> ActionLocation
-    pathLocation (Path Empty) = HereActions
-    pathLocation _ = ChildActions
+    pathLocation p = if p == mempty then HereActions else ChildActions
 
 -- todo: consider inlining these into Actions2
 addTermName :: Referent -> NameSegment -> Branch0 m -> Branch0 m

parser-typechecker/src/Unison/Codebase/Branch/Type.hs

@@ -39,7 +39,8 @@ import Unison.Codebase.Causal.Type (Causal)
 import Unison.Codebase.Causal.Type qualified as Causal
 import Unison.Codebase.Metadata qualified as Metadata
 import Unison.Codebase.Patch (Patch)
-import Unison.Codebase.Path (Path (..))
+import Unison.Codebase.Path (Path)
+import Unison.Codebase.Path qualified as Path
 import Unison.Hash qualified as Hash
 import Unison.Name (Name)
 import Unison.Name qualified as Name
@@ -269,7 +270,7 @@ deriveDeepPaths branch =
               paths =
                 if isEmpty0 b0
                   then Set.empty
-                  else (Set.singleton . Path . Seq.fromList . reverse) reversePrefix
+                  else (Set.singleton . Path.fromList . reverse) reversePrefix
           children <- deepChildrenHelper e
           go (work <> children) (paths <> acc)
 

parser-typechecker/src/Unison/Codebase/BranchUtil.hs

@@ -25,8 +25,7 @@ import Unison.Codebase.Branch (Branch, Branch0)
 import Unison.Codebase.Branch qualified as Branch
 import Unison.Codebase.Path (Path)
 import Unison.Codebase.Path qualified as Path
-import Unison.HashQualifiedPrime (HashQualified (HashQualified, NameOnly))
-import Unison.NameSegment (NameSegment)
+import Unison.HashQualifiedPrime qualified as HQ'
 import Unison.Names (Names)
 import Unison.Names qualified as Names
 import Unison.Prelude
@@ -47,46 +46,46 @@ fromNames names0 = Branch.stepManyAt (typeActions <> termActions) Branch.empty
     doTerm (n, r) = makeAddTermName (Path.splitFromName n) r
     doType (n, r) = makeAddTypeName (Path.splitFromName n) r
 
-getTerm :: Path.HQSplit -> Branch0 m -> Set Referent
-getTerm (p, hq) b = case hq of
-  NameOnly n -> Star2.lookupD1 n terms
-  HashQualified n sh -> filter sh $ Star2.lookupD1 n terms
+getTerm :: HQ'.HashQualified (Path.Split Path) -> Branch0 m -> Set Referent
+getTerm hq b = case hq of
+  HQ'.NameOnly (p, n) -> Star2.lookupD1 n $ terms p
+  HQ'.HashQualified (p, n) sh -> filter sh . Star2.lookupD1 n $ terms p
   where
     filter sh = Set.filter (SH.isPrefixOf sh . Referent.toShortHash)
-    terms = (Branch.getAt0 p b) ^. Branch.terms
+    terms p = (Branch.getAt0 p b) ^. Branch.terms
 
-getType :: Path.HQSplit -> Branch0 m -> Set Reference.TypeReference
-getType (p, hq) b = case hq of
-  NameOnly n -> Star2.lookupD1 n types
-  HashQualified n sh -> filter sh $ Star2.lookupD1 n types
+getType :: HQ'.HashQualified (Path.Split Path) -> Branch0 m -> Set Reference.TypeReference
+getType hq b = case hq of
+  HQ'.NameOnly (p, n) -> Star2.lookupD1 n $ types p
+  HQ'.HashQualified (p, n) sh -> filter sh . Star2.lookupD1 n $ types p
   where
     filter sh = Set.filter (SH.isPrefixOf sh . Reference.toShortHash)
-    types = (Branch.getAt0 p b) ^. Branch.types
+    types p = (Branch.getAt0 p b) ^. Branch.types
 
-getBranch :: Path.Split -> Branch0 m -> Maybe (Branch m)
+getBranch :: Path.Split Path -> Branch0 m -> Maybe (Branch m)
 getBranch (p, seg) b = case Path.toList p of
   [] -> Map.lookup seg (b ^. Branch.children)
   h : p ->
     (Branch.head <$> Map.lookup h (b ^. Branch.children))
       >>= getBranch (Path.fromList p, seg)
 
-makeAddTermName :: (p, NameSegment) -> Referent -> (p, Branch0 m -> Branch0 m)
+makeAddTermName :: Path.Split p -> Referent -> (p, Branch0 m -> Branch0 m)
 makeAddTermName (p, name) r = (p, Branch.addTermName r name)
 
-makeDeleteTermName :: (p, NameSegment) -> Referent -> (p, Branch0 m -> Branch0 m)
+makeDeleteTermName :: Path.Split p -> Referent -> (p, Branch0 m -> Branch0 m)
 makeDeleteTermName (p, name) r = (p, Branch.deleteTermName r name)
 
-makeAnnihilateTermName :: Path.Split -> (Path, Branch0 m -> Branch0 m)
+makeAnnihilateTermName :: Path.Split path -> (path, Branch0 m -> Branch0 m)
 makeAnnihilateTermName (p, name) = (p, Branch.annihilateTermName name)
 
-makeAnnihilateTypeName :: Path.Split -> (Path, Branch0 m -> Branch0 m)
+makeAnnihilateTypeName :: Path.Split path -> (path, Branch0 m -> Branch0 m)
 makeAnnihilateTypeName (p, name) = (p, Branch.annihilateTypeName name)
 
-makeAddTypeName :: (p, NameSegment) -> Reference -> (p, Branch0 m -> Branch0 m)
+makeAddTypeName :: Path.Split p -> Reference -> (p, Branch0 m -> Branch0 m)
 makeAddTypeName (p, name) r = (p, Branch.addTypeName r name)
 
-makeDeleteTypeName :: (p, NameSegment) -> Reference -> (p, Branch0 m -> Branch0 m)
+makeDeleteTypeName :: Path.Split p -> Reference -> (p, Branch0 m -> Branch0 m)
 makeDeleteTypeName (p, name) r = (p, Branch.deleteTypeName r name)
 
-makeSetBranch :: Path.Split -> Branch m -> (Path, Branch0 m -> Branch0 m)
+makeSetBranch :: Path.Split path -> Branch m -> (path, Branch0 m -> Branch0 m)
 makeSetBranch (p, name) b = (p, Branch.setChildBranch name b)

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

@@ -6,6 +6,7 @@ import Unison.NameSegment qualified as NameSegment
 import Unison.Prelude
 import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
 import Unison.Share.Types
+import Unison.Util.Recursion qualified as Rec
 
 data ShareCodeserver
   = DefaultCodeserver
@@ -44,7 +45,7 @@ printWriteRemoteNamespace projectAndBranch = into @Text projectAndBranch
 
 maybePrintPath :: Path -> Text
 maybePrintPath path =
-  if path == Path.empty
+  if path == mempty
     then mempty
     else "." <> Path.toText path
 
@@ -64,7 +65,6 @@ data ReadShareLooseCode = ReadShareLooseCode
   deriving stock (Eq, Show)
 
 isPublic :: ReadShareLooseCode -> Bool
-isPublic ReadShareLooseCode {path} =
-  case path of
-    (segment Path.:< _) -> segment == NameSegment.publicLooseCodeSegment
-    _ -> False
+isPublic ReadShareLooseCode {path} = case Rec.project path of
+  Rec.Neither -> False
+  Rec.Both segment _ -> segment == NameSegment.publicLooseCodeSegment