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

import Control.Lens hiding ((??))
import Control.Lens.Cons qualified as Cons
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 qualified as NameSegment
import Unison.Prelude
import Unison.Server.Backend
import Unison.Sqlite qualified as Sqlite

-- | 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 -> HQ.HashQualified Name -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction (Either BackendError (Path, HQ.HashQualified Name))
relocateToNameRoot :: Path
-> HashQualified Name
-> Branch Transaction
-> Transaction (Either BackendError (Path, HashQualified Name))
relocateToNameRoot Path
perspective HashQualified Name
query Branch Transaction
rootBranch = do
  let queryLocation :: Path
queryLocation = HashQualified Name -> Maybe Name
forall n. HashQualified n -> Maybe n
HQ.toName HashQualified Name
query Maybe Name -> (Maybe Name -> Path) -> Path
forall a b. a -> (a -> b) -> b
& Path -> (Name -> Path) -> Maybe Name -> Path
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Path
perspective \Name
name -> Path
perspective Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<> Name -> Path
Path.fromName Name
name
  -- Names should be found from the project root of the queried name
  (Path -> Branch Transaction -> Transaction (Maybe Path)
inferNamesRoot Path
queryLocation Branch Transaction
rootBranch) Transaction (Maybe Path)
-> (Maybe Path
    -> Transaction (Either BackendError (Path, HashQualified Name)))
-> Transaction (Either BackendError (Path, HashQualified Name))
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Path
Nothing -> do
      Either BackendError (Path, HashQualified Name)
-> Transaction (Either BackendError (Path, HashQualified Name))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BackendError (Path, HashQualified Name)
 -> Transaction (Either BackendError (Path, HashQualified Name)))
-> Either BackendError (Path, HashQualified Name)
-> Transaction (Either BackendError (Path, HashQualified Name))
forall a b. (a -> b) -> a -> b
$ (Path, HashQualified Name)
-> Either BackendError (Path, HashQualified Name)
forall a b. b -> Either a b
Right (Path
perspective, HashQualified Name
query)
    Just Path
projectRoot ->
      case Path -> Path -> (Path, Path, Path)
Path.longestPathPrefix Path
perspective Path
projectRoot of
        -- The perspective is equal to the project root
        (Path
_sharedPrefix, Path
Path.Empty, Path
Path.Empty) -> do
          Either BackendError (Path, HashQualified Name)
-> Transaction (Either BackendError (Path, HashQualified Name))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BackendError (Path, HashQualified Name)
 -> Transaction (Either BackendError (Path, HashQualified Name)))
-> Either BackendError (Path, HashQualified Name)
-> Transaction (Either BackendError (Path, HashQualified Name))
forall a b. (a -> b) -> a -> b
$ (Path, HashQualified Name)
-> Either BackendError (Path, HashQualified Name)
forall a b. b -> Either a b
Right (Path
perspective, HashQualified Name
query)
        -- The perspective is _outside_ of the project containing the query
        (Path
_sharedPrefix, Path
Path.Empty, Path
remainder) -> do
          -- Since the project root is lower down we need to strip the part of the prefix
          -- which is now redundant.
          Either BackendError (Path, HashQualified Name)
-> Transaction (Either BackendError (Path, HashQualified Name))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BackendError (Path, HashQualified Name)
 -> Transaction (Either BackendError (Path, HashQualified Name)))
-> ((Path, HashQualified Name)
    -> Either BackendError (Path, HashQualified Name))
-> (Path, HashQualified Name)
-> Transaction (Either BackendError (Path, HashQualified Name))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path, HashQualified Name)
-> Either BackendError (Path, HashQualified Name)
forall a b. b -> Either a b
Right ((Path, HashQualified Name)
 -> Transaction (Either BackendError (Path, HashQualified Name)))
-> (Path, HashQualified Name)
-> Transaction (Either BackendError (Path, HashQualified Name))
forall a b. (a -> b) -> a -> b
$ (Path
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
$ Absolute -> Name -> Maybe Name
Path.unprefixName (Path -> Absolute
Path.Absolute Path
remainder) Name
n)
        -- The namesRoot is _inside (or equal to)_ the project containing the query
        (Path
_sharedPrefix, Path
remainder, Path
Path.Empty) -> do
          -- Since the project is higher up, we need to prefix the query
          -- with the remainder of the path
          Either BackendError (Path, HashQualified Name)
-> Transaction (Either BackendError (Path, HashQualified Name))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BackendError (Path, HashQualified Name)
 -> Transaction (Either BackendError (Path, HashQualified Name)))
-> Either BackendError (Path, HashQualified Name)
-> Transaction (Either BackendError (Path, HashQualified Name))
forall a b. (a -> b) -> a -> b
$ (Path, HashQualified Name)
-> Either BackendError (Path, HashQualified Name)
forall a b. b -> Either a b
Right (Path
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 -> Path') -> Relative -> Path'
forall a b. (a -> b) -> a -> b
$ Path -> Relative
Path.Relative Path
remainder))
        -- The namesRoot and project root are disjoint, this shouldn't ever happen.
        (Path
_, Path
_, Path
_) -> Either BackendError (Path, HashQualified Name)
-> Transaction (Either BackendError (Path, HashQualified Name))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BackendError (Path, HashQualified Name)
 -> Transaction (Either BackendError (Path, HashQualified Name)))
-> Either BackendError (Path, HashQualified Name)
-> Transaction (Either BackendError (Path, HashQualified Name))
forall a b. (a -> b) -> a -> b
$ BackendError -> Either BackendError (Path, HashQualified Name)
forall a b. a -> Either a b
Left (Path -> Path -> BackendError
DisjointProjectAndPerspective Path
perspective Path
projectRoot)

-- | 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 -> Branch Sqlite.Transaction -> Sqlite.Transaction (Maybe Path)
inferNamesRoot :: Path -> Branch Transaction -> Transaction (Maybe Path)
inferNamesRoot Path
p Branch Transaction
b
  | Just Path
match <- Path -> Maybe Path
findBaseProject Path
p = Maybe Path -> Transaction (Maybe Path)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Path -> Transaction (Maybe Path))
-> Maybe Path -> Transaction (Maybe Path)
forall a b. (a -> b) -> a -> b
$ Path -> Maybe Path
forall a. a -> Maybe a
Just Path
match
  | Just Path
depRoot <- Path -> Maybe Path
findDepRoot Path
p = Maybe Path -> Transaction (Maybe Path)
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Path -> Transaction (Maybe Path))
-> Maybe Path -> Transaction (Maybe Path)
forall a b. (a -> b) -> a -> b
$ Path -> Maybe Path
forall a. a -> Maybe a
Just Path
depRoot
  | Bool
otherwise = Last Path -> Maybe Path
forall a. Last a -> Maybe a
getLast (Last Path -> Maybe Path)
-> Transaction (Last Path) -> Transaction (Maybe Path)
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 Path
p Branch Transaction
b) Path
Path.empty)
  where
    findBaseProject :: Path -> Maybe Path
    findBaseProject :: Path -> Maybe Path
findBaseProject
      (NameSegment
public Cons.:< NameSegment
base Cons.:< NameSegment
release Cons.:< Path
_rest) =
        if NameSegment
public NameSegment -> NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== NameSegment
NameSegment.publicLooseCodeSegment Bool -> Bool -> Bool
&& NameSegment
base NameSegment -> NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== NameSegment
NameSegment.baseSegment
          then Path -> Maybe Path
forall a. a -> Maybe a
Just ([NameSegment] -> Path
Path.fromList [NameSegment
public, NameSegment
base, NameSegment
release])
          else Maybe Path
forall a. Maybe a
Nothing
    findBaseProject Path
_ = Maybe Path
forall a. Maybe a
Nothing
    go :: Path -> Branch Sqlite.Transaction -> ReaderT Path (WriterT (Last Path) Sqlite.Transaction) ()
    go :: Path
-> Branch Transaction
-> ReaderT Path (WriterT (Last Path) Transaction) ()
go Path
p 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
      case Path
p of
        Path
Path.Empty -> () -> 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 ()
        (NameSegment
nextChild Cons.:< Path
pathRemainder) ->
          case 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 of
            Maybe (CausalBranch Transaction)
Nothing -> () -> 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 ()
            Just CausalBranch Transaction
childCausal -> do
              Branch Transaction
childBranch <- 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))
-> (Transaction (Branch Transaction)
    -> WriterT (Last Path) Transaction (Branch Transaction))
-> Transaction (Branch 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)
 -> ReaderT
      Path (WriterT (Last Path) Transaction) (Branch Transaction))
-> Transaction (Branch Transaction)
-> ReaderT
     Path (WriterT (Last Path) Transaction) (Branch Transaction)
forall a b. (a -> b) -> a -> b
$ CausalBranch Transaction -> Transaction (Branch Transaction)
forall (m :: * -> *) hc he pe e. Causal m hc he pe e -> m e
Causal.value CausalBranch Transaction
childCausal
              (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 s a. Snoc s s a a => s -> a -> s
Cons.|> NameSegment
nextChild) (Path
-> Branch Transaction
-> ReaderT Path (WriterT (Last Path) Transaction) ()
go Path
pathRemainder Branch Transaction
childBranch)

-- | 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
lib Cons.:< NameSegment
depRoot Cons.:< Path
rest)
  | NameSegment
lib NameSegment -> NameSegment -> Bool
forall a. Eq a => a -> a -> Bool
== NameSegment
NameSegment.libSegment =
      -- Keep looking to see if the full path is actually in a transitive dependency, otherwise
      -- fallback to this spot
      (([NameSegment] -> Path
Path.fromList [NameSegment
lib, NameSegment
depRoot] Path -> Path -> Path
forall a. Semigroup a => a -> a -> a
<>) (Path -> Path) -> Maybe Path -> Maybe Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path -> Maybe Path
findDepRoot Path
rest)
        Maybe Path -> Maybe Path -> Maybe Path
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Path -> Maybe Path
forall a. a -> Maybe a
Just ([NameSegment] -> Path
Path.fromList [NameSegment
lib, NameSegment
depRoot])
findDepRoot (NameSegment
other Cons.:< Path
rest) = (NameSegment
other NameSegment -> Path -> Path
forall b a. Cons b b a a => a -> b -> b
Cons.:<) (Path -> Path) -> Maybe Path -> Maybe Path
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path -> Maybe Path
findDepRoot Path
rest
findDepRoot Path
_ = Maybe Path
forall a. Maybe a
Nothing