-- | Helpers which are specific to the local share server.
module Unison.Server.Local (relocateToNameRoot) where

import Control.Lens hiding ((??))
import Control.Monad.Reader
import Control.Monad.Writer.Strict (WriterT, execWriterT, tell)
import Data.Map qualified as Map
import Data.Monoid (Last (..))
import U.Codebase.Branch
import U.Codebase.Branch qualified as V2Branch
import U.Codebase.Causal qualified as Causal
import Unison.Codebase.Path
import Unison.Codebase.Path qualified as Path
import Unison.HashQualified qualified as HQ
import Unison.Name (Name)
import Unison.NameSegment (NameSegment)
import Unison.NameSegment qualified as NameSegment
import Unison.Prelude
import Unison.Server.Backend
import Unison.Sqlite qualified as Sqlite
import Unison.Util.Recursion (Algebra, XNor (Both, Neither), cata)

-- | Given an arbitrary query and perspective, find the name root the query belongs in,
-- then return that root and the query relocated to that root.
--
-- A name root is either a project root or a dependency root.
-- E.g. @.myproject.some.namespace -> .myproject@ or @.myproject.lib.base.List -> .myproject.lib.base@
relocateToNameRoot ::
  Path.Absolute ->
  HQ.HashQualified Name ->
  V2Branch.Branch Sqlite.Transaction ->
  Sqlite.Transaction (Either BackendError (Path.Absolute, HQ.HashQualified Name))
relocateToNameRoot :: Absolute
-> HashQualified Name
-> Branch Transaction
-> Transaction (Either BackendError (Absolute, HashQualified Name))
relocateToNameRoot Absolute
perspective HashQualified Name
query =
  let queryLocation :: Absolute
queryLocation = Absolute -> (Name -> Absolute) -> Maybe Name -> Absolute
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Absolute
perspective (Absolute -> Path' -> Absolute
forall l r o. Resolve l r o => l -> r -> o
Path.resolve Absolute
perspective (Path' -> Absolute) -> (Name -> Path') -> Name -> Absolute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Path'
Path.fromName') (Maybe Name -> Absolute) -> Maybe Name -> Absolute
forall a b. (a -> b) -> a -> b
$ HashQualified Name -> Maybe Name
forall n. HashQualified n -> Maybe n
HQ.toName HashQualified Name
query
   in -- Names should be found from the project root of the queried name
      (Maybe Absolute
 -> Either BackendError (Absolute, HashQualified Name))
-> Transaction (Maybe Absolute)
-> Transaction (Either BackendError (Absolute, HashQualified Name))
forall a b. (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ( Either BackendError (Absolute, HashQualified Name)
-> (Absolute -> Either BackendError (Absolute, HashQualified Name))
-> Maybe Absolute
-> Either BackendError (Absolute, HashQualified Name)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            ((Absolute, HashQualified Name)
-> Either BackendError (Absolute, HashQualified Name)
forall a b. b -> Either a b
Right (Absolute
perspective, HashQualified Name
query))
            ( \Absolute
projectRoot -> case Absolute -> Absolute -> (Absolute, Relative, Relative)
Path.longestPathPrefix Absolute
perspective Absolute
projectRoot of
                -- The perspective is equal to the project root
                (Absolute
_sharedPrefix, Relative
Path.Current, Relative
Path.Current) -> (Absolute, HashQualified Name)
-> Either BackendError (Absolute, HashQualified Name)
forall a b. b -> Either a b
Right (Absolute
perspective, HashQualified Name
query)
                -- The perspective is _outside_ of the project containing the query
                (Absolute
_sharedPrefix, Relative
Path.Current, Relative
remainder) ->
                  -- Since the project root is lower down we need to strip the part of the prefix
                  -- which is now redundant.
                  (Absolute, HashQualified Name)
-> Either BackendError (Absolute, HashQualified Name)
forall a b. b -> Either a b
Right ((Absolute, HashQualified Name)
 -> Either BackendError (Absolute, HashQualified Name))
-> (Absolute, HashQualified Name)
-> Either BackendError (Absolute, HashQualified Name)
forall a b. (a -> b) -> a -> b
$ (Absolute
projectRoot, HashQualified Name
query HashQualified Name -> (Name -> Name) -> HashQualified Name
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Name
n -> Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
n (Maybe Name -> Name) -> Maybe Name -> Name
forall a b. (a -> b) -> a -> b
$ Relative -> Name -> Maybe Name
Path.unprefixName Relative
remainder Name
n)
                -- The namesRoot is _inside_ the project containing the query
                (Absolute
_sharedPrefix, Relative
remainder, Relative
Path.Current) ->
                  -- Since the project is higher up, we need to prefix the query
                  -- with the remainder of the path
                  (Absolute, HashQualified Name)
-> Either BackendError (Absolute, HashQualified Name)
forall a b. b -> Either a b
Right (Absolute
projectRoot, HashQualified Name
query HashQualified Name -> (Name -> Name) -> HashQualified Name
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Path' -> Name -> Name
Path.prefixNameIfRel (Relative -> Path'
Path.RelativePath' Relative
remainder))
                -- The namesRoot and project root are disjoint, this shouldn't ever happen.
                (Absolute
_, Relative
_, Relative
_) -> BackendError -> Either BackendError (Absolute, HashQualified Name)
forall a b. a -> Either a b
Left (Absolute -> Absolute -> BackendError
DisjointProjectAndPerspective Absolute
perspective Absolute
projectRoot)
            )
        )
        (Transaction (Maybe Absolute)
 -> Transaction
      (Either BackendError (Absolute, HashQualified Name)))
-> (Branch Transaction -> Transaction (Maybe Absolute))
-> Branch Transaction
-> Transaction (Either BackendError (Absolute, HashQualified Name))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Absolute -> Branch Transaction -> Transaction (Maybe Absolute)
inferNamesRoot Absolute
queryLocation

-- | When folded, this extracts a specific path prefix, plus one extra segment.
--
--   If the first argument is `Just`, the list is used to match subsequences that aren’t at the start of the list.
segsPlusOne :: Maybe [NameSegment] -> Algebra (XNor NameSegment) ([NameSegment] -> Maybe [NameSegment])
segsPlusOne :: Maybe [NameSegment]
-> Algebra
     (XNor NameSegment) ([NameSegment] -> Maybe [NameSegment])
segsPlusOne Maybe [NameSegment]
unanchored = \case
  XNor NameSegment ([NameSegment] -> Maybe [NameSegment])
Neither -> Maybe [NameSegment] -> [NameSegment] -> Maybe [NameSegment]
forall a b. a -> b -> a
const Maybe [NameSegment]
forall a. Maybe a
Nothing
  Both NameSegment
seg [NameSegment] -> Maybe [NameSegment]
fn -> \case
    [] -> [NameSegment] -> Maybe [NameSegment]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [NameSegment
seg]
    NameSegment
next : [NameSegment]
rest -> ([NameSegment] -> [NameSegment])
-> Maybe [NameSegment] -> Maybe [NameSegment]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NameSegment
next NameSegment -> [NameSegment] -> [NameSegment]
forall a. a -> [a] -> [a]
:) (Maybe [NameSegment] -> Maybe [NameSegment])
-> ([NameSegment] -> Maybe [NameSegment])
-> [NameSegment]
-> Maybe [NameSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NameSegment] -> Maybe [NameSegment]
fn ([NameSegment] -> Maybe [NameSegment])
-> Maybe [NameSegment] -> Maybe [NameSegment]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< if NameSegment
seg NameSegment -> NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== NameSegment
next then [NameSegment] -> Maybe [NameSegment]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [NameSegment]
rest else Maybe [NameSegment]
unanchored

-- | Infers path to use for loading names.
--
-- A name root is either a project root or a dependency root.
-- E.g. @.myproject.some.namespace -> .myproject@ (where .myproject.lib exists) or @.myproject.lib.base.List -> .myproject.lib.base@
inferNamesRoot :: Path.Absolute -> Branch Sqlite.Transaction -> Sqlite.Transaction (Maybe Path.Absolute)
inferNamesRoot :: Absolute -> Branch Transaction -> Transaction (Maybe Absolute)
inferNamesRoot Absolute
p Branch Transaction
b
  | Just Absolute
match <- Absolute -> Maybe Absolute
findBaseProject Absolute
p = Maybe Absolute -> Transaction (Maybe Absolute)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Absolute -> Transaction (Maybe Absolute))
-> Maybe Absolute -> Transaction (Maybe Absolute)
forall a b. (a -> b) -> a -> b
$ Absolute -> Maybe Absolute
forall a. a -> Maybe a
Just Absolute
match
  | Just Path
depRoot <- Path -> Maybe Path
findDepRoot (Absolute -> Path
Path.unabsolute Absolute
p) = Maybe Absolute -> Transaction (Maybe Absolute)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Absolute -> Transaction (Maybe Absolute))
-> (Absolute -> Maybe Absolute)
-> Absolute
-> Transaction (Maybe Absolute)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Absolute -> Maybe Absolute
forall a. a -> Maybe a
Just (Absolute -> Transaction (Maybe Absolute))
-> Absolute -> Transaction (Maybe Absolute)
forall a b. (a -> b) -> a -> b
$ Path -> Absolute
Path.Absolute Path
depRoot
  | Bool
otherwise = (Path -> Absolute) -> Maybe Path -> Maybe Absolute
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path -> Absolute
Path.Absolute (Maybe Path -> Maybe Absolute)
-> (Last Path -> Maybe Path) -> Last Path -> Maybe Absolute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Last Path -> Maybe Path
forall a. Last a -> Maybe a
getLast (Last Path -> Maybe Absolute)
-> Transaction (Last Path) -> Transaction (Maybe Absolute)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WriterT (Last Path) Transaction () -> Transaction (Last Path)
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (ReaderT Path (WriterT (Last Path) Transaction) ()
-> Path -> WriterT (Last Path) Transaction ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Path
-> Branch Transaction
-> ReaderT Path (WriterT (Last Path) Transaction) ()
go (Absolute -> Path
Path.unabsolute Absolute
p) Branch Transaction
b) Path
forall a. Monoid a => a
mempty)
  where
    findBaseProject :: Path.Absolute -> Maybe Path.Absolute
    findBaseProject :: Absolute -> Maybe Absolute
findBaseProject =
      ([NameSegment] -> Absolute)
-> Maybe [NameSegment] -> Maybe Absolute
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path -> Absolute
Path.Absolute (Path -> Absolute)
-> ([NameSegment] -> Path) -> [NameSegment] -> Absolute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NameSegment] -> Path
Path.fromList)
        (Maybe [NameSegment] -> Maybe Absolute)
-> (Absolute -> Maybe [NameSegment]) -> Absolute -> Maybe Absolute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Absolute -> [NameSegment] -> Maybe [NameSegment])
-> [NameSegment] -> Absolute -> Maybe [NameSegment]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Algebra (XNor NameSegment) ([NameSegment] -> Maybe [NameSegment])
-> Absolute -> [NameSegment] -> Maybe [NameSegment]
forall a. Algebra (XNor NameSegment) a -> Absolute -> a
forall t (f :: * -> *) a. Recursive t f => Algebra f a -> t -> a
cata (Algebra (XNor NameSegment) ([NameSegment] -> Maybe [NameSegment])
 -> Absolute -> [NameSegment] -> Maybe [NameSegment])
-> Algebra
     (XNor NameSegment) ([NameSegment] -> Maybe [NameSegment])
-> Absolute
-> [NameSegment]
-> Maybe [NameSegment]
forall a b. (a -> b) -> a -> b
$ Maybe [NameSegment]
-> Algebra
     (XNor NameSegment) ([NameSegment] -> Maybe [NameSegment])
segsPlusOne Maybe [NameSegment]
forall a. Maybe a
Nothing) [NameSegment
NameSegment.publicLooseCodeSegment, NameSegment
NameSegment.baseSegment]
    go :: Path -> Branch Sqlite.Transaction -> ReaderT Path (WriterT (Last Path) Sqlite.Transaction) ()
    go :: Path
-> Branch Transaction
-> ReaderT Path (WriterT (Last Path) Transaction) ()
go = Algebra
  (XNor NameSegment)
  (Branch Transaction
   -> ReaderT Path (WriterT (Last Path) Transaction) ())
-> Path
-> Branch Transaction
-> ReaderT Path (WriterT (Last Path) Transaction) ()
forall a. Algebra (XNor NameSegment) a -> Path -> a
forall t (f :: * -> *) a. Recursive t f => Algebra f a -> t -> a
cata \case
      XNor
  NameSegment
  (Branch Transaction
   -> ReaderT Path (WriterT (Last Path) Transaction) ())
Neither -> ReaderT Path (WriterT (Last Path) Transaction) ()
-> Branch Transaction
-> ReaderT Path (WriterT (Last Path) Transaction) ()
forall a b. a -> b -> a
const (ReaderT Path (WriterT (Last Path) Transaction) ()
 -> Branch Transaction
 -> ReaderT Path (WriterT (Last Path) Transaction) ())
-> ReaderT Path (WriterT (Last Path) Transaction) ()
-> Branch Transaction
-> ReaderT Path (WriterT (Last Path) Transaction) ()
forall a b. (a -> b) -> a -> b
$ () -> ReaderT Path (WriterT (Last Path) Transaction) ()
forall a. a -> ReaderT Path (WriterT (Last Path) Transaction) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Both NameSegment
nextChild Branch Transaction
-> ReaderT Path (WriterT (Last Path) Transaction) ()
fn -> \Branch Transaction
b -> do
        Map NameSegment (CausalBranch Transaction)
childMap <- WriterT
  (Last Path)
  Transaction
  (Map NameSegment (CausalBranch Transaction))
-> ReaderT
     Path
     (WriterT (Last Path) Transaction)
     (Map NameSegment (CausalBranch Transaction))
forall (m :: * -> *) a. Monad m => m a -> ReaderT Path m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT
   (Last Path)
   Transaction
   (Map NameSegment (CausalBranch Transaction))
 -> ReaderT
      Path
      (WriterT (Last Path) Transaction)
      (Map NameSegment (CausalBranch Transaction)))
-> (Transaction (Map NameSegment (CausalBranch Transaction))
    -> WriterT
         (Last Path)
         Transaction
         (Map NameSegment (CausalBranch Transaction)))
-> Transaction (Map NameSegment (CausalBranch Transaction))
-> ReaderT
     Path
     (WriterT (Last Path) Transaction)
     (Map NameSegment (CausalBranch Transaction))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction (Map NameSegment (CausalBranch Transaction))
-> WriterT
     (Last Path)
     Transaction
     (Map NameSegment (CausalBranch Transaction))
forall (m :: * -> *) a. Monad m => m a -> WriterT (Last Path) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction (Map NameSegment (CausalBranch Transaction))
 -> ReaderT
      Path
      (WriterT (Last Path) Transaction)
      (Map NameSegment (CausalBranch Transaction)))
-> Transaction (Map NameSegment (CausalBranch Transaction))
-> ReaderT
     Path
     (WriterT (Last Path) Transaction)
     (Map NameSegment (CausalBranch Transaction))
forall a b. (a -> b) -> a -> b
$ Branch Transaction
-> Transaction (Map NameSegment (CausalBranch Transaction))
forall (m :: * -> *).
Branch m -> Transaction (Map NameSegment (CausalBranch m))
nonEmptyChildren Branch Transaction
b
        Bool
-> ReaderT Path (WriterT (Last Path) Transaction) ()
-> ReaderT Path (WriterT (Last Path) Transaction) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (CausalBranch Transaction) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (CausalBranch Transaction) -> Bool)
-> Maybe (CausalBranch Transaction) -> Bool
forall a b. (a -> b) -> a -> b
$ NameSegment
-> Map NameSegment (CausalBranch Transaction)
-> Maybe (CausalBranch Transaction)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NameSegment
NameSegment.libSegment Map NameSegment (CausalBranch Transaction)
childMap) (ReaderT Path (WriterT (Last Path) Transaction) ()
 -> ReaderT Path (WriterT (Last Path) Transaction) ())
-> ReaderT Path (WriterT (Last Path) Transaction) ()
-> ReaderT Path (WriterT (Last Path) Transaction) ()
forall a b. (a -> b) -> a -> b
$ ReaderT Path (WriterT (Last Path) Transaction) Path
forall r (m :: * -> *). MonadReader r m => m r
ask ReaderT Path (WriterT (Last Path) Transaction) Path
-> (Path -> ReaderT Path (WriterT (Last Path) Transaction) ())
-> ReaderT Path (WriterT (Last Path) Transaction) ()
forall a b.
ReaderT Path (WriterT (Last Path) Transaction) a
-> (a -> ReaderT Path (WriterT (Last Path) Transaction) b)
-> ReaderT Path (WriterT (Last Path) Transaction) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Last Path -> ReaderT Path (WriterT (Last Path) Transaction) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Last Path -> ReaderT Path (WriterT (Last Path) Transaction) ())
-> (Path -> Last Path)
-> Path
-> ReaderT Path (WriterT (Last Path) Transaction) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Path -> Last Path
forall a. Maybe a -> Last a
Last (Maybe Path -> Last Path)
-> (Path -> Maybe Path) -> Path -> Last Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Maybe Path
forall a. a -> Maybe a
Just
        ReaderT Path (WriterT (Last Path) Transaction) ()
-> (CausalBranch Transaction
    -> ReaderT Path (WriterT (Last Path) Transaction) ())
-> Maybe (CausalBranch Transaction)
-> ReaderT Path (WriterT (Last Path) Transaction) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ReaderT Path (WriterT (Last Path) Transaction) ()
forall a. a -> ReaderT Path (WriterT (Last Path) Transaction) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ((Path -> Path)
-> ReaderT Path (WriterT (Last Path) Transaction) ()
-> ReaderT Path (WriterT (Last Path) Transaction) ()
forall a.
(Path -> Path)
-> ReaderT Path (WriterT (Last Path) Transaction) a
-> ReaderT Path (WriterT (Last Path) Transaction) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Path -> NameSegment -> Path
forall path. Pathy path => path -> NameSegment -> path
`Path.descend` NameSegment
nextChild) (ReaderT Path (WriterT (Last Path) Transaction) ()
 -> ReaderT Path (WriterT (Last Path) Transaction) ())
-> (Branch Transaction
    -> ReaderT Path (WriterT (Last Path) Transaction) ())
-> Branch Transaction
-> ReaderT Path (WriterT (Last Path) Transaction) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Branch Transaction
-> ReaderT Path (WriterT (Last Path) Transaction) ()
fn (Branch Transaction
 -> ReaderT Path (WriterT (Last Path) Transaction) ())
-> (CausalBranch Transaction
    -> ReaderT
         Path (WriterT (Last Path) Transaction) (Branch Transaction))
-> CausalBranch Transaction
-> ReaderT Path (WriterT (Last Path) Transaction) ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< WriterT (Last Path) Transaction (Branch Transaction)
-> ReaderT
     Path (WriterT (Last Path) Transaction) (Branch Transaction)
forall (m :: * -> *) a. Monad m => m a -> ReaderT Path m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT (Last Path) Transaction (Branch Transaction)
 -> ReaderT
      Path (WriterT (Last Path) Transaction) (Branch Transaction))
-> (CausalBranch Transaction
    -> WriterT (Last Path) Transaction (Branch Transaction))
-> CausalBranch Transaction
-> ReaderT
     Path (WriterT (Last Path) Transaction) (Branch Transaction)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction (Branch Transaction)
-> WriterT (Last Path) Transaction (Branch Transaction)
forall (m :: * -> *) a. Monad m => m a -> WriterT (Last Path) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Transaction (Branch Transaction)
 -> WriterT (Last Path) Transaction (Branch Transaction))
-> (CausalBranch Transaction -> Transaction (Branch Transaction))
-> CausalBranch Transaction
-> WriterT (Last Path) Transaction (Branch Transaction)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CausalBranch Transaction -> Transaction (Branch Transaction)
forall (m :: * -> *) hc he pe e. Causal m hc he pe e -> m e
Causal.value) (Maybe (CausalBranch Transaction)
 -> ReaderT Path (WriterT (Last Path) Transaction) ())
-> Maybe (CausalBranch Transaction)
-> ReaderT Path (WriterT (Last Path) Transaction) ()
forall a b. (a -> b) -> a -> b
$
          NameSegment
-> Map NameSegment (CausalBranch Transaction)
-> Maybe (CausalBranch Transaction)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (NameSegment -> NameSegment
forall a b. Coercible a b => a -> b
coerce NameSegment
nextChild) Map NameSegment (CausalBranch Transaction)
childMap

-- | If the provided path is within a lib dir (or a transitive lib) find the dependency
-- we're in.
--
-- E.g. @.myproject.lib.base.List -> .myproject.lib.base@
-- E.g. @.myproject.lib.distributed.lib.base.List -> .myproject.lib.distributed.lib.base@
--
-- >>> findDepRoot (Path.fromList ["myproject", "lib", "base", "List"])
-- Just myproject.lib.base
--
-- >>> findDepRoot (Path.fromList ["myproject", "lib", "distributed", "lib", "base", "List"])
-- Just myproject.lib.distributed.lib.base
--
-- Just lib isn't inside a dependency.
-- >>> findDepRoot (Path.fromList ["myproject", "lib"])
-- Nothing
findDepRoot :: Path -> Maybe Path
findDepRoot :: Path -> Maybe Path
findDepRoot = ([NameSegment] -> Path) -> Maybe [NameSegment] -> Maybe Path
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [NameSegment] -> Path
Path.fromList (Maybe [NameSegment] -> Maybe Path)
-> (Path -> Maybe [NameSegment]) -> Path -> Maybe Path
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> [NameSegment] -> Maybe [NameSegment])
-> [NameSegment] -> Path -> Maybe [NameSegment]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Algebra (XNor NameSegment) ([NameSegment] -> Maybe [NameSegment])
-> Path -> [NameSegment] -> Maybe [NameSegment]
forall a. Algebra (XNor NameSegment) a -> Path -> a
forall t (f :: * -> *) a. Recursive t f => Algebra f a -> t -> a
cata (Algebra (XNor NameSegment) ([NameSegment] -> Maybe [NameSegment])
 -> Path -> [NameSegment] -> Maybe [NameSegment])
-> (Maybe [NameSegment]
    -> Algebra
         (XNor NameSegment) ([NameSegment] -> Maybe [NameSegment]))
-> Maybe [NameSegment]
-> Path
-> [NameSegment]
-> Maybe [NameSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [NameSegment]
-> Algebra
     (XNor NameSegment) ([NameSegment] -> Maybe [NameSegment])
segsPlusOne (Maybe [NameSegment]
 -> Path -> [NameSegment] -> Maybe [NameSegment])
-> Maybe [NameSegment]
-> Path
-> [NameSegment]
-> Maybe [NameSegment]
forall a b. (a -> b) -> a -> b
$ [NameSegment] -> Maybe [NameSegment]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [NameSegment
NameSegment.libSegment]) [NameSegment
NameSegment.libSegment]