mirror of
https://github.com/unisonweb/unison.git
synced 2024-10-04 05:37:14 +03:00
Checkpoint
This commit is contained in:
Chris Penner
parent
29fd307ad9
commit
2c98ad1b1e
@ -50,7 +50,7 @@ module Unison.Codebase
|
||||
getShallowCausalAtPath,
|
||||
getBranchAtPath,
|
||||
Operations.expectCausalBranchByCausalHash,
|
||||
getShallowCausalFromRoot,
|
||||
getShallowCausalAtPathFromRootHash,
|
||||
getShallowRootBranch,
|
||||
getShallowRootCausal,
|
||||
getShallowProjectRootBranch,
|
||||
@ -184,15 +184,13 @@ runTransactionWithRollback ::
|
||||
runTransactionWithRollback Codebase {withConnection} action =
|
||||
withConnection \conn -> Sqlite.runTransactionWithRollback conn action
|
||||
|
||||
getShallowCausalFromRoot ::
|
||||
-- Optional root branch, if Nothing use the codebase's root branch.
|
||||
Maybe CausalHash ->
|
||||
getShallowCausalAtPathFromRootHash ::
|
||||
-- Causal to start at, if Nothing use the codebase's root branch.
|
||||
CausalHash ->
|
||||
Path.Path ->
|
||||
Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction)
|
||||
getShallowCausalFromRoot mayRootHash p = do
|
||||
rootCausal <- case mayRootHash of
|
||||
Nothing -> getShallowRootCausal
|
||||
Just ch -> Operations.expectCausalBranchByCausalHash ch
|
||||
getShallowCausalAtPathFromRootHash rootCausalHash p = do
|
||||
rootCausal <- Operations.expectCausalBranchByCausalHash rootCausalHash
|
||||
getShallowCausalAtPath p (Just rootCausal)
|
||||
|
||||
-- | Get the shallow representation of the root branches without loading the children or
|
||||
@ -240,19 +238,18 @@ getShallowBranchAtPath path branch = do
|
||||
childBranch <- V2Causal.value childCausal
|
||||
getShallowBranchAtPath p childBranch
|
||||
|
||||
getShallowProjectRootBranch :: Db.ProjectId -> Db.ProjectBranchId -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
||||
getShallowProjectRootBranch projectId projectBranchId = do
|
||||
ProjectBranch {causalHashId} <- Q.expectProjectBranch projectId projectBranchId
|
||||
getShallowProjectRootBranch :: ProjectBranch -> Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
||||
getShallowProjectRootBranch ProjectBranch {causalHashId} = do
|
||||
causalHash <- Q.expectCausalHash causalHashId
|
||||
Operations.expectCausalBranchByCausalHash causalHash >>= V2Causal.value
|
||||
|
||||
-- | Recursively descend into causals following the given path,
|
||||
-- Use the root causal if none is provided.
|
||||
getShallowBranchAtProjectPath ::
|
||||
PP.ProjectPathIds ->
|
||||
PP.ProjectPath ->
|
||||
Sqlite.Transaction (V2Branch.Branch Sqlite.Transaction)
|
||||
getShallowBranchAtProjectPath (PP.ProjectPath projectId projectBranchId path) = do
|
||||
projectRootBranch <- getShallowProjectRootBranch projectId projectBranchId
|
||||
getShallowBranchAtProjectPath (PP.ProjectPath _project projectBranch path) = do
|
||||
projectRootBranch <- getShallowProjectRootBranch projectBranch
|
||||
getShallowBranchAtPath (Path.unabsolute path) projectRootBranch
|
||||
|
||||
getShallowProjectRootByNames :: ProjectAndBranch ProjectName ProjectBranchName -> Sqlite.Transaction (Maybe (V2Branch.CausalBranch Sqlite.Transaction))
|
||||
|
||||
@ -11,8 +11,6 @@ module Unison.Codebase.ProjectPath
|
||||
asIds_,
|
||||
asNames_,
|
||||
asProjectAndBranch_,
|
||||
project_,
|
||||
branch_,
|
||||
)
|
||||
where
|
||||
|
||||
@ -27,11 +25,11 @@ import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
|
||||
data ProjectPathG proj branch = ProjectPath
|
||||
{ projPathProject :: proj,
|
||||
projPathBranch :: branch,
|
||||
projPathPath :: Path.Absolute
|
||||
{ project :: proj,
|
||||
branch :: branch,
|
||||
absPath :: Path.Absolute
|
||||
}
|
||||
deriving stock (Eq, Ord, Show)
|
||||
deriving stock (Eq, Ord, Show, Generic)
|
||||
|
||||
type ProjectPathIds = ProjectPathG ProjectId ProjectBranchId
|
||||
|
||||
@ -42,18 +40,6 @@ type ProjectPath = ProjectPathG Project ProjectBranch
|
||||
fromProjectAndBranch :: ProjectAndBranch Project ProjectBranch -> Path.Absolute -> ProjectPath
|
||||
fromProjectAndBranch (ProjectAndBranch proj branch) path = ProjectPath proj branch path
|
||||
|
||||
project_ :: Lens' (ProjectPathG p b) p
|
||||
project_ = lens get set
|
||||
where
|
||||
get (ProjectPath p _ _) = p
|
||||
set (ProjectPath _ b path) p = ProjectPath p b path
|
||||
|
||||
branch_ :: Lens' (ProjectPathG p b) b
|
||||
branch_ = lens get set
|
||||
where
|
||||
get (ProjectPath _ b _) = b
|
||||
set (ProjectPath p _ path) b = ProjectPath p b path
|
||||
|
||||
-- | Project a project context into a project path of just IDs
|
||||
asIds_ :: Lens' ProjectPath ProjectPathIds
|
||||
asIds_ = lens get set
|
||||
@ -61,8 +47,8 @@ asIds_ = lens get set
|
||||
get (ProjectPath proj branch path) = ProjectPath (proj ^. #projectId) (branch ^. #branchId) path
|
||||
set p (ProjectPath pId bId path) =
|
||||
p
|
||||
& project_ . #projectId .~ pId
|
||||
& branch_ . #branchId .~ bId
|
||||
& #project . #projectId .~ pId
|
||||
& #branch . #branchId .~ bId
|
||||
& absPath_ .~ path
|
||||
|
||||
-- | Project a project context into a project path of just names
|
||||
@ -72,15 +58,15 @@ asNames_ = lens get set
|
||||
get (ProjectPath proj branch path) = ProjectPath (proj ^. #name) (branch ^. #name) path
|
||||
set p (ProjectPath pName bName path) =
|
||||
p
|
||||
& project_ . #name .~ pName
|
||||
& branch_ . #name .~ bName
|
||||
& #project . #name .~ pName
|
||||
& #branch . #name .~ bName
|
||||
& absPath_ .~ path
|
||||
|
||||
asProjectAndBranch_ :: Lens' ProjectPath (ProjectAndBranch Project ProjectBranch)
|
||||
asProjectAndBranch_ = lens get set
|
||||
where
|
||||
get (ProjectPath proj branch _) = ProjectAndBranch proj branch
|
||||
set p (ProjectAndBranch proj branch) = p & project_ .~ proj & branch_ .~ branch
|
||||
set p (ProjectAndBranch proj branch) = p & #project .~ proj & #branch .~ branch
|
||||
|
||||
instance Bifunctor ProjectPathG where
|
||||
bimap f g (ProjectPath p b path) = ProjectPath (f p) (g b) path
|
||||
|
||||
@ -8,7 +8,7 @@ module Unison.Cli.MonadUtils
|
||||
getCurrentPath,
|
||||
getCurrentProjectName,
|
||||
getCurrentProjectBranchName,
|
||||
getProjectPath,
|
||||
getCurrentProjectPath,
|
||||
resolvePath,
|
||||
resolvePath',
|
||||
resolveSplit',
|
||||
@ -95,8 +95,6 @@ import U.Codebase.Branch qualified as V2 (Branch)
|
||||
import U.Codebase.Branch qualified as V2Branch
|
||||
import U.Codebase.Causal qualified as V2Causal
|
||||
import U.Codebase.HashTags (CausalHash (..))
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
@ -146,28 +144,28 @@ getConfig key = do
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Getting paths, path resolution, etc.
|
||||
|
||||
getProjectPath :: Cli PP.ProjectPath
|
||||
getProjectPath = do
|
||||
getCurrentProjectPath :: Cli PP.ProjectPath
|
||||
getCurrentProjectPath = do
|
||||
(PP.ProjectPath projId branchId path) <- Cli.getProjectPathIds
|
||||
-- TODO: Reset to a valid project on error.
|
||||
(Project {name = projName}, ProjectBranch {name = branchName}) <- fmap (fromMaybe (error $ reportBug "E794202" ("Project branch not found in database for ids: " <> show (projId, branchId)))) . Cli.runTransaction . runMaybeT $ do
|
||||
(proj, branch) <- fmap (fromMaybe (error $ reportBug "E794202" ("Project branch not found in database for ids: " <> show (projId, branchId)))) . Cli.runTransaction . runMaybeT $ do
|
||||
project <- MaybeT $ Q.loadProject projId
|
||||
branch <- MaybeT $ Q.loadProjectBranch projId branchId
|
||||
pure (project, branch)
|
||||
pure (PP.ProjectPath (projId, projName) (branchId, branchName) path)
|
||||
pure (PP.ProjectPath proj branch path)
|
||||
|
||||
-- | Get the current path relative to the current project.
|
||||
getCurrentPath :: Cli Path.Absolute
|
||||
getCurrentPath = do
|
||||
view PP.absPath_ <$> getProjectPath
|
||||
view PP.absPath_ <$> getCurrentProjectPath
|
||||
|
||||
getCurrentProjectName :: Cli ProjectName
|
||||
getCurrentProjectName = do
|
||||
view (PP.ctxAsNames_ . PP.project_) <$> getProjectPath
|
||||
view (PP.asNames_ . #project) <$> getCurrentProjectPath
|
||||
|
||||
getCurrentProjectBranchName :: Cli ProjectBranchName
|
||||
getCurrentProjectBranchName = do
|
||||
view (PP.ctxAsNames_ . PP.branch_) <$> getProjectPath
|
||||
view (PP.asNames_ . #branch) <$> getCurrentProjectPath
|
||||
|
||||
-- | Resolve a @Path@ (interpreted as relative) to a @Path.Absolute@, per the current path.
|
||||
resolvePath :: Path -> Cli Path.Absolute
|
||||
|
||||
@ -13,8 +13,6 @@ module Unison.Cli.ProjectUtils
|
||||
expectProjectAndBranchByIds,
|
||||
getProjectAndBranchByTheseNames,
|
||||
expectProjectAndBranchByTheseNames,
|
||||
getCurrentProject,
|
||||
getCurrentProjectBranch,
|
||||
|
||||
-- * Loading remote project info
|
||||
expectRemoteProjectById,
|
||||
@ -40,7 +38,6 @@ import Data.These (These (..))
|
||||
import U.Codebase.Sqlite.DbId
|
||||
import U.Codebase.Sqlite.Project (Project)
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch)
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
@ -66,13 +63,13 @@ resolveBranchRelativePath brp = do
|
||||
case brp of
|
||||
BranchPathInCurrentProject projBranchName path -> do
|
||||
projectAndBranch <- expectProjectAndBranchByTheseNames (That projBranchName)
|
||||
pure $ PP.ctxFromProjectAndBranch projectAndBranch path
|
||||
pure $ PP.fromProjectAndBranch projectAndBranch path
|
||||
QualifiedBranchPath projName projBranchName path -> do
|
||||
projectAndBranch <- expectProjectAndBranchByTheseNames (These projName projBranchName)
|
||||
pure $ PP.ctxFromProjectAndBranch projectAndBranch path
|
||||
pure $ PP.fromProjectAndBranch projectAndBranch path
|
||||
UnqualifiedPath newPath' -> do
|
||||
ppCtx <- Cli.getProjectPath
|
||||
pure $ ppCtx & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath'
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
pure $ pp & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath'
|
||||
|
||||
-- @findTemporaryBranchName projectId preferred@ finds some unused branch name in @projectId@ with a name
|
||||
-- like @preferred@.
|
||||
@ -95,20 +92,6 @@ findTemporaryBranchName projectId preferred = do
|
||||
|
||||
pure (fromJust (List.find (\name -> not (Set.member name allBranchNames)) allCandidates))
|
||||
|
||||
-- | Get the current project+branch+branch path that a user is on.
|
||||
getCurrentProjectBranch :: Cli (PP.ProjectPath Sqlite.Project Sqlite.ProjectBranch)
|
||||
getCurrentProjectBranch = do
|
||||
ppCtx <- Cli.getProjectPath
|
||||
Cli.runTransaction $ do
|
||||
proj <- Queries.expectProject (ppCtx ^. PP.ctxAsIds_ . PP.project_)
|
||||
branch <- Queries.expectProjectBranch (proj ^. #projectId) (ppCtx ^. PP.ctxAsIds_ . PP.branch_)
|
||||
pure $ PP.ProjectPath proj branch (ppCtx ^. PP.absPath_)
|
||||
|
||||
getCurrentProject :: Cli Sqlite.Project
|
||||
getCurrentProject = do
|
||||
ppCtx <- Cli.getProjectPath
|
||||
Cli.runTransaction (Queries.expectProject (ppCtx ^. PP.ctxAsIds_ . PP.project_))
|
||||
|
||||
expectProjectBranchByName :: Sqlite.Project -> ProjectBranchName -> Cli Sqlite.ProjectBranch
|
||||
expectProjectBranchByName project branchName =
|
||||
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
|
||||
@ -124,8 +107,8 @@ hydrateNames :: These ProjectName ProjectBranchName -> Cli (ProjectAndBranch Pro
|
||||
hydrateNames = \case
|
||||
This projectName -> pure (ProjectAndBranch projectName (unsafeFrom @Text "main"))
|
||||
That branchName -> do
|
||||
ppCtx <- Cli.getProjectPath
|
||||
pure (ProjectAndBranch (ppCtx ^. PP.ctxAsNames_ . PP.project_) branchName)
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
pure (ProjectAndBranch (pp ^. PP.asNames_ . #project) branchName)
|
||||
These projectName branchName -> pure (ProjectAndBranch projectName branchName)
|
||||
|
||||
-- Expect a local project+branch by ids.
|
||||
@ -147,9 +130,9 @@ getProjectAndBranchByTheseNames ::
|
||||
getProjectAndBranchByTheseNames = \case
|
||||
This projectName -> getProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
|
||||
That branchName -> runMaybeT do
|
||||
currentProjectBranch <- lift getCurrentProjectBranch
|
||||
branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (currentProjectBranch ^. PP.project_ . #projectId) branchName))
|
||||
pure (ProjectAndBranch (currentProjectBranch ^. PP.project_) branch)
|
||||
(PP.ProjectPath proj _branch _path) <- lift Cli.getCurrentProjectPath
|
||||
branch <- MaybeT (Cli.runTransaction (Queries.loadProjectBranchByName (proj ^. #projectId) branchName))
|
||||
pure (ProjectAndBranch proj branch)
|
||||
These projectName branchName -> do
|
||||
Cli.runTransaction do
|
||||
runMaybeT do
|
||||
@ -167,7 +150,7 @@ expectProjectAndBranchByTheseNames ::
|
||||
expectProjectAndBranchByTheseNames = \case
|
||||
This projectName -> expectProjectAndBranchByTheseNames (These projectName (unsafeFrom @Text "main"))
|
||||
That branchName -> do
|
||||
PP.ProjectPath project _branch _restPath <- getCurrentProjectBranch
|
||||
PP.ProjectPath project _branch _restPath <- Cli.getCurrentProjectPath
|
||||
branch <-
|
||||
Cli.runTransaction (Queries.loadProjectBranchByName (project ^. #projectId) branchName) & onNothingM do
|
||||
Cli.returnEarly (LocalProjectBranchDoesntExist (ProjectAndBranch (project ^. #name) branchName))
|
||||
@ -188,21 +171,21 @@ expectProjectAndBranchByTheseNames = \case
|
||||
-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the current
|
||||
-- project, defaulting to 'main' if branch is unspecified.
|
||||
-- 3. If we just have a path, resolve it using the current project.
|
||||
resolveProjectPath :: PP.ProjectPath -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Maybe Path' -> Cli PP.ProjectPath
|
||||
resolveProjectPath ppCtx mayProjAndBranch mayPath' = do
|
||||
projAndBranch <- resolveProjectBranch ppCtx mayProjAndBranch
|
||||
resolveProjectPath :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Maybe Path' -> Cli PP.ProjectPath
|
||||
resolveProjectPath defaultProj mayProjAndBranch mayPath' = do
|
||||
projAndBranch <- resolveProjectBranch defaultProj mayProjAndBranch
|
||||
absPath <- fromMaybe Path.absoluteEmpty <$> traverse Cli.resolvePath' mayPath'
|
||||
pure $ PP.ctxFromProjectAndBranch projAndBranch absPath
|
||||
pure $ PP.fromProjectAndBranch projAndBranch absPath
|
||||
|
||||
-- | Expect/resolve branch reference with the following rules:
|
||||
--
|
||||
-- 1. If the project is missing, use the provided project.
|
||||
-- 2. If we have an unambiguous `/branch` or `project/branch`, resolve it using the provided
|
||||
-- project, defaulting to 'main' if branch is unspecified.
|
||||
resolveProjectBranch :: ProjectAndBranch Project ProjectBranch -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
||||
resolveProjectBranch ppCtx (ProjectAndBranch mayProjectName mayBranchName) = do
|
||||
resolveProjectBranch :: Project -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
|
||||
resolveProjectBranch defaultProj (ProjectAndBranch mayProjectName mayBranchName) = do
|
||||
let branchName = fromMaybe (unsafeFrom @Text "main") mayBranchName
|
||||
let projectName = fromMaybe (ppCtx ^. PP.ctxAsNames_ . PP.project_) mayProjectName
|
||||
let projectName = fromMaybe (defaultProj ^. #name) mayProjectName
|
||||
projectAndBranch <- expectProjectAndBranchByTheseNames (These projectName branchName)
|
||||
pure projectAndBranch
|
||||
|
||||
@ -289,7 +272,7 @@ expectRemoteProjectBranchByTheseNames includeSquashed = \case
|
||||
let remoteBranchName = unsafeFrom @Text "main"
|
||||
expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
|
||||
That branchName -> do
|
||||
PP.ProjectPath localProject localBranch _restPath <- getCurrentProjectBranch
|
||||
PP.ProjectPath localProject localBranch _restPath <- Cli.getCurrentProjectPath
|
||||
let localProjectId = localProject ^. #projectId
|
||||
let localBranchId = localBranch ^. #branchId
|
||||
Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
|
||||
|
||||
@ -18,10 +18,8 @@ import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch (headHash)
|
||||
import Unison.Codebase.Editor.Input qualified as Input
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, classifyProjectBranchName)
|
||||
@ -41,7 +39,7 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB
|
||||
Cli.returnEarly (Output.CannotCreateReleaseBranchWithBranchCommand newBranchName ver)
|
||||
ProjectBranchNameKind'NothingSpecial -> pure ()
|
||||
|
||||
currentProjectName <- Cli.getProjectPath <&> view (PP.ctxAsNames_ . PP.project_)
|
||||
currentProjectName <- Cli.getCurrentProjectPath <&> view (PP.asNames_ . #project)
|
||||
destProject <- do
|
||||
Cli.runTransactionWithRollback
|
||||
\rollback -> do
|
||||
@ -51,22 +49,21 @@ handleBranch sourceI projectAndBranchNames@(ProjectAndBranch mayProjectName newB
|
||||
rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName newBranchName))
|
||||
|
||||
-- Compute what we should create the branch from.
|
||||
maySrcBranch <-
|
||||
maySrcProjectAndBranch <-
|
||||
case sourceI of
|
||||
Input.BranchSourceI'CurrentContext -> Just <$> ProjectUtils.getCurrentProjectBranch
|
||||
Input.BranchSourceI'CurrentContext -> Just . view PP.projectAndBranch_ <$> Cli.getCurrentProjectPath
|
||||
Input.BranchSourceI'Empty -> pure Nothing
|
||||
Input.BranchSourceI'UnresolvedProjectBranch unresolvedProjectBranch -> do
|
||||
ppCtx <- Cli.getProjectPath
|
||||
ProjectAndBranch _proj branch <- ProjectUtils.resolveProjectBranch ppCtx (unresolvedProjectBranch & #branch %~ Just)
|
||||
pure $ Just branch
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
Just <$> ProjectUtils.resolveProjectBranch (pp ^. #project) (unresolvedProjectBranch & #branch %~ Just)
|
||||
|
||||
_ <- doCreateBranch maySrcBranch project newBranchName
|
||||
_ <- doCreateBranch (view #branch <$> maySrcProjectAndBranch) destProject newBranchName
|
||||
|
||||
Cli.respond $
|
||||
Output.CreatedProjectBranch
|
||||
( case maySrcBranch of
|
||||
( case maySrcProjectAndBranch of
|
||||
Just sourceBranch ->
|
||||
if sourceBranch ^. #project . #projectId == project ^. #projectId
|
||||
if sourceBranch ^. #project . #projectId == destProject ^. #projectId
|
||||
then Output.CreatedProjectBranchFrom'ParentBranch (sourceBranch ^. #branch . #name)
|
||||
else Output.CreatedProjectBranchFrom'OtherBranch sourceBranch
|
||||
Nothing -> Output.CreatedProjectBranchFrom'Nothingness
|
||||
@ -86,7 +83,7 @@ doCreateBranch ::
|
||||
-- If no parent branch is provided, make an empty branch.
|
||||
Maybe Sqlite.ProjectBranch ->
|
||||
Sqlite.Project ->
|
||||
Sqlite.Transaction ProjectBranchName ->
|
||||
ProjectBranchName ->
|
||||
Cli ProjectBranchId
|
||||
doCreateBranch mayParentBranch project getNewBranchName = do
|
||||
let projectId = project ^. #projectId
|
||||
|
||||
@ -21,6 +21,7 @@ import Unison.Cli.ProjectUtils qualified as Project
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ProjectPath qualified as PP
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
|
||||
import Unison.ConstructorType qualified as ConstructorType
|
||||
import Unison.HashQualified qualified as HQ
|
||||
@ -28,8 +29,7 @@ import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.Parser.Ann (Ann (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch)
|
||||
import Unison.Project.Util (projectBranchPath)
|
||||
import Unison.Project (ProjectAndBranch (ProjectAndBranch))
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Server.CodebaseServer qualified as Server
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
@ -39,37 +39,25 @@ import Web.Browser (openBrowser)
|
||||
openUI :: Path.Path' -> Cli ()
|
||||
openUI path' = do
|
||||
Cli.Env {serverBaseUrl} <- ask
|
||||
currentPath <- Cli.getCurrentPath
|
||||
let absPath = Path.resolve currentPath path'
|
||||
defnPath <- Cli.resolvePath' path'
|
||||
pp <- Cli.getCurrentProjectPath
|
||||
whenJust serverBaseUrl \url -> do
|
||||
Project.getProjectBranchForPath absPath >>= \case
|
||||
Nothing -> openUIForLooseCode url path'
|
||||
Just (projectBranch, pathWithinBranch) -> openUIForProject url projectBranch pathWithinBranch
|
||||
openUIForProject url pp defnPath
|
||||
|
||||
openUIForProject :: Server.BaseUrl -> ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Path.Path -> Cli ()
|
||||
openUIForProject url projectAndBranch pathFromProjectRoot = do
|
||||
currentPath <- Cli.getCurrentPath
|
||||
perspective <-
|
||||
Project.getProjectBranchForPath currentPath <&> \case
|
||||
Nothing ->
|
||||
-- The current path is outside the project the argument was in. Use the project root
|
||||
-- as the perspective.
|
||||
Path.empty
|
||||
Just (_projectBranch, pathWithinBranch) -> pathWithinBranch
|
||||
openUIForProject :: Server.BaseUrl -> PP.ProjectPath -> Path.Absolute -> Cli ()
|
||||
openUIForProject url (PP.ProjectPath project projectBranch perspective) defnPath = do
|
||||
mayDefinitionRef <- getDefinitionRef perspective
|
||||
let projectBranchNames = bimap Project.name ProjectBranch.name projectAndBranch
|
||||
let projectBranchNames = bimap Project.name ProjectBranch.name (ProjectAndBranch project projectBranch)
|
||||
_success <- liftIO . openBrowser . Text.unpack $ Server.urlFor (Server.ProjectBranchUI projectBranchNames perspective mayDefinitionRef) url
|
||||
pure ()
|
||||
where
|
||||
pathToBranchFromCodebaseRoot :: Path.Absolute
|
||||
pathToBranchFromCodebaseRoot = projectBranchPath (bimap Project.projectId ProjectBranch.branchId projectAndBranch)
|
||||
-- If the provided ui path matches a definition, find it.
|
||||
getDefinitionRef :: Path.Path -> Cli (Maybe (Server.DefinitionReference))
|
||||
getDefinitionRef :: Path.Absolute -> Cli (Maybe (Server.DefinitionReference))
|
||||
getDefinitionRef perspective = runMaybeT $ do
|
||||
Cli.Env {codebase} <- lift ask
|
||||
let absPathToDefinition = Path.unabsolute $ Path.resolve pathToBranchFromCodebaseRoot (Path.Relative pathFromProjectRoot)
|
||||
(pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc absPathToDefinition
|
||||
namespaceBranch <- lift $ Cli.runTransaction (Codebase.getShallowBranchAtPath pathToDefinitionNamespace Nothing)
|
||||
(pathToDefinitionNamespace, _nameSeg) <- hoistMaybe $ Lens.unsnoc defnPath
|
||||
let defnNamespaceProjectPath = pp & PP.absPath_ .~ pathToDefinitionNamespace
|
||||
namespaceBranch <- lift . Cli.runTransaction $ Codebase.getShallowBranchAtProjectPath defnNamespaceProjectPath
|
||||
fqn <- hoistMaybe $ do
|
||||
pathFromPerspective <- List.stripPrefix (Path.toList perspective) (Path.toList pathFromProjectRoot)
|
||||
Path.toName . Path.fromList $ pathFromPerspective
|
||||
|
||||
@ -101,7 +101,7 @@ noCompletions ::
|
||||
String ->
|
||||
Codebase m v a ->
|
||||
AuthenticatedHttpClient ->
|
||||
Path.Absolute ->
|
||||
PP.ProjectPath ->
|
||||
m [System.Console.Haskeline.Completion.Completion]
|
||||
noCompletions _ _ _ _ = pure []
|
||||
|
||||
@ -145,7 +145,7 @@ completeWithinNamespace ::
|
||||
Sqlite.Transaction [System.Console.Haskeline.Completion.Completion]
|
||||
completeWithinNamespace compTypes query ppCtx = do
|
||||
shortHashLen <- Codebase.hashLength
|
||||
b <- Codebase.getShallowBranchAtProjectPath (queryProjectPath ^. PP.ctxAsIds_)
|
||||
b <- Codebase.getShallowBranchAtProjectPath (queryProjectPath ^. PP.asIds_)
|
||||
currentBranchSuggestions <- do
|
||||
nib <- namesInBranch shortHashLen b
|
||||
nib
|
||||
|
||||
@ -177,7 +177,7 @@ projectBranchOptions codebase _projCtx _searchBranch0 = do
|
||||
-- E.g. '@unison/base/main'
|
||||
projectBranchOptionsWithinCurrentProject :: OptionFetcher
|
||||
projectBranchOptionsWithinCurrentProject codebase projCtx _searchBranch0 = do
|
||||
Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. PP.asIds_ . PP.project_) Nothing)
|
||||
Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. PP.asIds_ . #project) Nothing)
|
||||
<&> fmap (into @Text . snd)
|
||||
|
||||
-- | Exported from here just so the debug command and actual implementation can use the same
|
||||
|
||||
@ -147,7 +147,7 @@ module Unison.CommandLine.InputPatterns
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens ((^.))
|
||||
import Control.Lens ((.~), (^.))
|
||||
import Control.Lens.Cons qualified as Cons
|
||||
import Data.List (intercalate)
|
||||
import Data.List.Extra qualified as List
|
||||
@ -1840,7 +1840,7 @@ mergeOldSquashInputPattern =
|
||||
[src, dest] -> do
|
||||
src <- parseUnresolvedProjectBranch src
|
||||
dest <- parseUnresolvedProjectBranch dest
|
||||
Just $ Input.MergeLocalBranchI src dest Branch.SquashMerge
|
||||
Just $ Input.MergeLocalBranchI src (Just dest) Branch.SquashMerge
|
||||
_ -> Nothing
|
||||
}
|
||||
where
|
||||
@ -3349,7 +3349,7 @@ namespaceOrProjectBranchArg config =
|
||||
ArgumentType
|
||||
{ typeName = "namespace or branch",
|
||||
suggestions =
|
||||
let namespaceSuggestions = \q cb _http ppCtx -> Codebase.runTransaction cb (prefixCompleteNamespace q ppCtx)
|
||||
let namespaceSuggestions = \q cb _http pp -> Codebase.runTransaction cb (prefixCompleteNamespace q pp)
|
||||
in unionSuggestions
|
||||
[ projectAndOrBranchSuggestions config,
|
||||
namespaceSuggestions
|
||||
@ -3375,8 +3375,8 @@ dependencyArg :: ArgumentType
|
||||
dependencyArg =
|
||||
ArgumentType
|
||||
{ typeName = "project dependency",
|
||||
suggestions = \q cb _http p -> Codebase.runTransaction cb do
|
||||
prefixCompleteNamespace q (p Path.:> NameSegment.libSegment),
|
||||
suggestions = \q cb _http pp -> Codebase.runTransaction cb do
|
||||
prefixCompleteNamespace q (pp & PP.path_ .~ Path.singleton NameSegment.libSegment),
|
||||
fzfResolver = Just Resolvers.projectDependencyResolver
|
||||
}
|
||||
|
||||
@ -3464,12 +3464,12 @@ projectAndOrBranchSuggestions ::
|
||||
AuthenticatedHttpClient ->
|
||||
ProjectPath ->
|
||||
m [Line.Completion]
|
||||
projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do
|
||||
projectAndOrBranchSuggestions config inputStr codebase _httpClient pp = do
|
||||
case Text.uncons input of
|
||||
-- Things like "/foo" would be parsed as unambiguous branches in the logic below, except we also want to
|
||||
-- handle "/<TAB>" and "/@<TAB>" inputs, which aren't valid branch names, but are valid branch prefixes. So,
|
||||
-- if the input begins with a forward slash, just rip it off and treat the rest as the branch prefix.
|
||||
Just ('/', input1) -> handleBranchesComplete input1 codebase path
|
||||
Just ('/', input1) -> handleBranchesComplete input1 codebase pp
|
||||
_ ->
|
||||
case tryInto @ProjectAndBranchNames input of
|
||||
-- This case handles inputs like "", "@", and possibly other things that don't look like a valid project
|
||||
@ -3490,12 +3490,12 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do
|
||||
Nothing -> pure []
|
||||
Just project -> do
|
||||
let projectId = project ^. #projectId
|
||||
fmap (filterBranches config path) do
|
||||
fmap (filterBranches config pp) do
|
||||
Queries.loadAllProjectBranchesBeginningWith projectId Nothing
|
||||
pure (map (projectBranchToCompletion projectName) branches)
|
||||
-- This branch is probably dead due to intercepting inputs that begin with "/" above
|
||||
Right (ProjectAndBranchNames'Unambiguous (That branchName)) ->
|
||||
handleBranchesComplete (into @Text branchName) codebase path
|
||||
handleBranchesComplete (into @Text branchName) codebase pp
|
||||
Right (ProjectAndBranchNames'Unambiguous (These projectName branchName)) -> do
|
||||
branches <-
|
||||
Codebase.runTransaction codebase do
|
||||
@ -3503,12 +3503,11 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do
|
||||
Nothing -> pure []
|
||||
Just project -> do
|
||||
let projectId = project ^. #projectId
|
||||
fmap (filterBranches config path) do
|
||||
fmap (filterBranches config pp) do
|
||||
Queries.loadAllProjectBranchesBeginningWith projectId (Just $ into @Text branchName)
|
||||
pure (map (projectBranchToCompletion projectName) branches)
|
||||
where
|
||||
input = Text.strip . Text.pack $ inputStr
|
||||
currentProjectId = ppCtx ^. (PP.ctxAsIds_ . PP.project_)
|
||||
|
||||
handleAmbiguousComplete ::
|
||||
MonadIO m =>
|
||||
@ -3519,14 +3518,10 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do
|
||||
(branches, projects) <-
|
||||
Codebase.runTransaction codebase do
|
||||
branches <-
|
||||
case mayCurrentProjectId of
|
||||
Nothing -> pure []
|
||||
Just currentProjectId ->
|
||||
fmap (filterBranches config path) do
|
||||
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input)
|
||||
projects <- case (projectInclusion config, mayCurrentProjectId) of
|
||||
(OnlyWithinCurrentProject, Just currentProjectId) -> Queries.loadProject currentProjectId <&> maybeToList
|
||||
(OnlyWithinCurrentProject, Nothing) -> pure []
|
||||
fmap (filterBranches config pp) do
|
||||
Queries.loadAllProjectBranchesBeginningWith currentProjectId (Just input)
|
||||
projects <- case projectInclusion config of
|
||||
OnlyWithinCurrentProject -> Queries.loadProject currentProjectId <&> maybeToList
|
||||
_ -> Queries.loadAllProjectsBeginningWith (Just input) <&> filterProjects
|
||||
pure (branches, projects)
|
||||
let branchCompletions = map currentProjectBranchToCompletion branches
|
||||
@ -3602,25 +3597,26 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient ppCtx = do
|
||||
|
||||
-- Complete the text into a branch name within the provided project
|
||||
handleBranchesComplete :: MonadIO m => Text -> Codebase m v a -> PP.ProjectPath -> m [Completion]
|
||||
handleBranchesComplete branchName codebase ppCtx = do
|
||||
let projId = ppCtx ^. PP.ctxAsIds_ . PP.project_
|
||||
handleBranchesComplete branchName codebase pp = do
|
||||
let projId = pp ^. PP.asIds_ . #project
|
||||
branches <-
|
||||
Codebase.runTransaction codebase do
|
||||
fmap (filterBranches config path) do
|
||||
fmap (filterBranches config pp) do
|
||||
Queries.loadAllProjectBranchesBeginningWith projId (Just branchName)
|
||||
pure (map currentProjectBranchToCompletion branches)
|
||||
|
||||
filterProjects :: [Sqlite.Project] -> [Sqlite.Project]
|
||||
filterProjects projects =
|
||||
case (mayCurrentProjectId, projectInclusion config) of
|
||||
(_, AllProjects) -> projects
|
||||
(Nothing, _) -> projects
|
||||
(Just currentProjId, OnlyOutsideCurrentProject) -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjId)
|
||||
(Just currentBranchId, OnlyWithinCurrentProject) ->
|
||||
case (projectInclusion config) of
|
||||
AllProjects -> projects
|
||||
OnlyOutsideCurrentProject -> projects & filter (\Sqlite.Project {projectId} -> projectId /= currentProjectId)
|
||||
OnlyWithinCurrentProject ->
|
||||
projects
|
||||
& List.find (\Sqlite.Project {projectId} -> projectId == currentBranchId)
|
||||
& List.find (\Sqlite.Project {projectId} -> projectId == currentProjectId)
|
||||
& maybeToList
|
||||
|
||||
PP.ProjectPath currentProjectId _currentBranchId _currentPath = pp ^. PP.asIds_
|
||||
|
||||
projectToCompletion :: Sqlite.Project -> Completion
|
||||
projectToCompletion project =
|
||||
Completion
|
||||
@ -3646,20 +3642,20 @@ handleBranchesComplete ::
|
||||
Codebase m v a ->
|
||||
PP.ProjectPath ->
|
||||
m [Completion]
|
||||
handleBranchesComplete config branchName codebase ppCtx = do
|
||||
handleBranchesComplete config branchName codebase pp = do
|
||||
branches <-
|
||||
Codebase.runTransaction codebase do
|
||||
fmap (filterBranches config ppCtx) do
|
||||
Queries.loadAllProjectBranchesBeginningWith (ppCtx ^. PP.ctxAsIds_ . PP.project_) (Just branchName)
|
||||
fmap (filterBranches config pp) do
|
||||
Queries.loadAllProjectBranchesBeginningWith (pp ^. PP.asIds_ . #project) (Just branchName)
|
||||
pure (map currentProjectBranchToCompletion branches)
|
||||
|
||||
filterBranches :: ProjectBranchSuggestionsConfig -> PP.ProjectPath -> [(ProjectBranchId, a)] -> [(ProjectBranchId, a)]
|
||||
filterBranches config ppCtx branches =
|
||||
filterBranches config pp branches =
|
||||
case (branchInclusion config) of
|
||||
AllBranches -> branches
|
||||
ExcludeCurrentBranch -> branches & filter (\(branchId, _) -> branchId /= currentBranchId)
|
||||
where
|
||||
currentBranchId = ppCtx ^. PP.ctxAsIds_ . PP.branch_
|
||||
currentBranchId = pp ^. PP.asIds_ . #branch
|
||||
|
||||
currentProjectBranchToCompletion :: (ProjectBranchId, ProjectBranchName) -> Completion
|
||||
currentProjectBranchToCompletion (_, branchName) =
|
||||
@ -3677,20 +3673,20 @@ branchRelativePathSuggestions ::
|
||||
AuthenticatedHttpClient ->
|
||||
PP.ProjectPath ->
|
||||
m [Line.Completion]
|
||||
branchRelativePathSuggestions config inputStr codebase _httpClient ppCtx = do
|
||||
branchRelativePathSuggestions config inputStr codebase _httpClient pp = do
|
||||
case parseIncrementalBranchRelativePath inputStr of
|
||||
Left _ -> pure []
|
||||
Right ibrp -> case ibrp of
|
||||
BranchRelativePath.ProjectOrPath' _txt _path -> do
|
||||
namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath)
|
||||
namespaceSuggestions <- Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp)
|
||||
projectSuggestions <- projectNameSuggestions WithSlash inputStr codebase
|
||||
pure (namespaceSuggestions ++ projectSuggestions)
|
||||
BranchRelativePath.OnlyPath' _path ->
|
||||
Codebase.runTransaction codebase (prefixCompleteNamespace inputStr currentPath)
|
||||
Codebase.runTransaction codebase (prefixCompleteNamespace inputStr pp)
|
||||
BranchRelativePath.IncompleteProject _proj ->
|
||||
projectNameSuggestions WithSlash inputStr codebase
|
||||
BranchRelativePath.IncompleteBranch mproj mbranch -> case mproj of
|
||||
Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase ppCtx
|
||||
Nothing -> map suffixPathSep <$> handleBranchesComplete config (maybe "" into mbranch) codebase pp
|
||||
Just projectName -> do
|
||||
branches <-
|
||||
Codebase.runTransaction codebase do
|
||||
@ -3698,18 +3694,16 @@ branchRelativePathSuggestions config inputStr codebase _httpClient ppCtx = do
|
||||
Nothing -> pure []
|
||||
Just project -> do
|
||||
let projectId = project ^. #projectId
|
||||
fmap (filterBranches config ppCtx) do
|
||||
fmap (filterBranches config pp) do
|
||||
Queries.loadAllProjectBranchesBeginningWith projectId (into @Text <$> mbranch)
|
||||
pure (map (projectBranchToCompletionWithSep projectName) branches)
|
||||
BranchRelativePath.PathRelativeToCurrentBranch relPath -> Codebase.runTransaction codebase do
|
||||
-- TODO: Verify this works as intendid
|
||||
map prefixPathSep <$> prefixCompleteNamespace (Path.convert relPath) mempty
|
||||
map prefixPathSep <$> prefixCompleteNamespace (Path.convert relPath) pp
|
||||
BranchRelativePath.IncompletePath projStuff mpath -> do
|
||||
Codebase.runTransaction codebase do
|
||||
map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" Path.convert mpath) ppCtx
|
||||
map (addBranchPrefix projStuff) <$> prefixCompleteNamespace (maybe "" Path.convert mpath) pp
|
||||
where
|
||||
currentPath = ppCtx ^. PP.absPath_
|
||||
|
||||
projectBranchToCompletionWithSep :: ProjectName -> (ProjectBranchId, ProjectBranchName) -> Completion
|
||||
projectBranchToCompletionWithSep projectName (_, branchName) =
|
||||
Completion
|
||||
|
||||
@ -83,7 +83,7 @@ getUserInput codebase authHTTPClient ppCtx currentProjectRoot numberedArgs =
|
||||
Just a -> pure a
|
||||
go :: Line.InputT IO Input
|
||||
go = do
|
||||
let (PP.ProjectPath projectName projectBranchName path) = ppCtx ^. PP.ctxAsNames_
|
||||
let (PP.ProjectPath projectName projectBranchName path) = ppCtx ^. PP.asNames_
|
||||
let promptString =
|
||||
P.sep
|
||||
":"
|
||||
|
||||
@ -45,7 +45,6 @@ import Unison.Auth.Types qualified as Auth
|
||||
import Unison.Builtin.Decls qualified as DD
|
||||
import Unison.Cli.MergeTypes (MergeSourceAndTarget (..))
|
||||
import Unison.Cli.Pretty
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.ServantClientUtils qualified as ServantClientUtils
|
||||
import Unison.Codebase.Editor.DisplayObject (DisplayObject (..))
|
||||
import Unison.Codebase.Editor.Input qualified as Input
|
||||
@ -455,7 +454,7 @@ notifyNumbered = \case
|
||||
)
|
||||
where
|
||||
switch = IP.makeExample IP.projectSwitch
|
||||
AmbiguousReset sourceOfAmbiguity (ProjectAndBranch pn0 bn0, path) (ProjectAndBranch currentProject branch) ->
|
||||
AmbiguousReset sourceOfAmbiguity (ProjectAndBranch _pn0 _bn0, path) (ProjectAndBranch currentProject branch) ->
|
||||
( P.wrap
|
||||
( openingLine
|
||||
<> prettyProjectAndBranchName (ProjectAndBranch currentProject branch)
|
||||
@ -495,7 +494,7 @@ notifyNumbered = \case
|
||||
E.AmbiguousReset'Target -> \xs -> "<some hash>" : xs
|
||||
reset = IP.makeExample IP.reset
|
||||
relPath0 = prettyPath path
|
||||
absPath0 = review ProjectUtils.projectBranchPathPrism (ProjectAndBranch (pn0 ^. #projectId) (bn0 ^. #branchId), path)
|
||||
absPath0 = Path.Absolute path
|
||||
ListNamespaceDependencies _ppe _path Empty -> ("This namespace has no external dependencies.", mempty)
|
||||
ListNamespaceDependencies ppe path' externalDependencies ->
|
||||
( P.column2Header (P.hiBlack "External dependency") ("Dependents in " <> prettyAbsolute path') $
|
||||
@ -910,7 +909,7 @@ notifyUser dir = \case
|
||||
prettyProjectAndBranchName projectAndBranch <> "is empty. There is nothing to push."
|
||||
CreatedNewBranch path ->
|
||||
pure $
|
||||
"☝️ The namespace " <> prettyAbsoluteStripProject path <> " is empty."
|
||||
"☝️ The namespace " <> prettyAbsolute path <> " is empty."
|
||||
-- RenameOutput rootPath oldName newName r -> do
|
||||
-- nameChange "rename" "renamed" oldName newName r
|
||||
-- AliasOutput rootPath existingName newName r -> do
|
||||
|
||||
@ -239,7 +239,7 @@ data DefinitionReference
|
||||
data Service
|
||||
= LooseCodeUI Path.Absolute (Maybe DefinitionReference)
|
||||
| -- (Project branch names, perspective within project, definition reference)
|
||||
ProjectBranchUI (ProjectAndBranch ProjectName ProjectBranchName) Path.Path (Maybe DefinitionReference)
|
||||
ProjectBranchUI (ProjectAndBranch ProjectName ProjectBranchName) Path.Absolute (Maybe DefinitionReference)
|
||||
| Api
|
||||
deriving stock (Show)
|
||||
|
||||
@ -299,13 +299,13 @@ urlFor :: Service -> BaseUrl -> Text
|
||||
urlFor service baseUrl =
|
||||
case service of
|
||||
LooseCodeUI perspective def ->
|
||||
tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "non-project-code"] <> path (Path.unabsolute perspective) def)
|
||||
tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "non-project-code"] <> path perspective def)
|
||||
ProjectBranchUI (ProjectAndBranch projectName branchName) perspective def ->
|
||||
tShow baseUrl <> "/" <> toUrlPath ([DontEscape "ui", DontEscape "projects", DontEscape $ into @Text projectName, DontEscape $ into @Text branchName] <> path perspective def)
|
||||
Api -> tShow baseUrl <> "/" <> toUrlPath [DontEscape "api"]
|
||||
where
|
||||
path :: Path.Path -> Maybe DefinitionReference -> [URISegment]
|
||||
path ns def =
|
||||
path :: Path.Absolute -> Maybe DefinitionReference -> [URISegment]
|
||||
path (Path.Absolute ns) def =
|
||||
let nsPath = namespacePath ns
|
||||
in case definitionPath def of
|
||||
Just defPath -> case nsPath of
|
||||
|
||||
Loading…
Reference in New Issue
Block a user