Add missing api instances

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

@@ -48,6 +48,7 @@ import Servant
     serve,
     throwError,
   )
+import Servant qualified as Servant
 import Servant.API
   ( Accept (..),
     Capture,
@@ -60,11 +61,13 @@ import Servant.API
   )
 import Servant.Docs
   ( DocIntro (DocIntro),
+    ToParam (..),
     ToSample (..),
     docsWithIntros,
     markdown,
     singleSample,
   )
+import Servant.Docs qualified as Servant
 import Servant.OpenApi (HasOpenApi (toOpenApi))
 import Servant.Server
   ( Application,
@@ -106,11 +109,15 @@ import Unison.Server.Local.Endpoints.NamespaceDetails qualified as NamespaceDeta
 import Unison.Server.Local.Endpoints.NamespaceListing qualified as NamespaceListing
 import Unison.Server.Local.Endpoints.Projects (ListProjectBranchesEndpoint, ListProjectsEndpoint, projectBranchListingEndpoint, projectListingEndpoint)
 import Unison.Server.Local.Endpoints.UCM (UCMAPI, ucmServer)
-import Unison.Server.Types (mungeString, setCacheControl)
+import Unison.Server.Types (TermDiffResponse, TypeDiffResponse, mungeString, setCacheControl)
+import Unison.Share.API.Projects (BranchName)
 import Unison.ShortHash qualified as ShortHash
 import Unison.Symbol (Symbol)
 import Unison.Syntax.NameSegment qualified as NameSegment
 
+-- | Fail the route with a reasonable error if the query param is missing.
+type RequiredQueryParam = Servant.QueryParam' '[Servant.Required, Servant.Strict]
+
 -- HTML content type
 data HTML = HTML
 
@@ -143,8 +150,49 @@ type CodebaseServerAPI =
 
 type ProjectsAPI =
   ListProjectsEndpoint
-    :<|> (Capture "project-name" ProjectName :> "branches" :> ListProjectBranchesEndpoint)
-    :<|> (Capture "project-name" ProjectName :> "branches" :> Capture "branch-name" ProjectBranchName :> CodebaseServerAPI)
+    :<|> ( Capture "project-name" ProjectName
+             :> "branches"
+             :> ( ListProjectBranchesEndpoint
+                    :<|> (Capture "branch-name" ProjectBranchName :> CodebaseServerAPI)
+                    :<|> ( "diff"
+                             :> ( "terms" :> ProjectDiffTermsEndpoint
+                                    :<|> "types" :> ProjectDiffTypesEndpoint
+                                )
+                         )
+                )
+         )
+
+type ProjectDiffTermsEndpoint =
+  RequiredQueryParam "oldBranchRef" BranchName
+    :> RequiredQueryParam "newBranchRef" BranchName
+    :> RequiredQueryParam "oldTerm" Name
+    :> RequiredQueryParam "newTerm" Name
+    :> Get '[JSON] TermDiffResponse
+
+type ProjectDiffTypesEndpoint =
+  RequiredQueryParam "oldBranchRef" BranchName
+    :> RequiredQueryParam "newBranchRef" BranchName
+    :> RequiredQueryParam "oldType" Name
+    :> RequiredQueryParam "newType" Name
+    :> Get '[JSON] TypeDiffResponse
+
+instance ToParam (Servant.QueryParam' mods "oldBranchRef" a) where
+  toParam _ = Servant.DocQueryParam "oldBranchRef" ["main"] "The name of the old branch" Servant.Normal
+
+instance ToParam (Servant.QueryParam' mods "newBranchRef" a) where
+  toParam _ = Servant.DocQueryParam "newBranchRef" ["main"] "The name of the new branch" Servant.Normal
+
+instance ToParam (Servant.QueryParam' mods "oldTerm" a) where
+  toParam _ = Servant.DocQueryParam "oldTerm" ["main"] "The name of the old term" Servant.Normal
+
+instance ToParam (Servant.QueryParam' mods "newTerm" a) where
+  toParam _ = Servant.DocQueryParam "newTerm" ["main"] "The name of the new term" Servant.Normal
+
+instance ToParam (Servant.QueryParam' mods "oldType" a) where
+  toParam _ = Servant.DocQueryParam "oldType" ["main"] "The name of the old type" Servant.Normal
+
+instance ToParam (Servant.QueryParam' mods "newType" a) where
+  toParam _ = Servant.DocQueryParam "newType" ["main"] "The name of the new type" Servant.Normal
 
 type WebUI = CaptureAll "route" Text :> Get '[HTML] RawHtml
 
@@ -558,11 +606,24 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do
         Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName)
         Just ch -> pure (Right ch)
 
+serveProjectDiffTermsEndpoint :: Codebase m v a -> ProjectName -> BranchName -> BranchName -> Name -> Name -> Backend IO TermDiffResponse
+serveProjectDiffTermsEndpoint projectName oldBranchRef newBranchRef oldTerm newTerm = do
+  undefined
+
+serveProjectDiffTypesEndpoint :: Codebase m v a -> ProjectName -> BranchName -> BranchName -> Name -> Name -> Backend IO TypeDiffResponse
+serveProjectDiffTypesEndpoint projectName oldBranchRef newBranchRef oldType newType = do
+  undefined
+
 serveProjectsAPI :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> ServerT ProjectsAPI (Backend IO)
 serveProjectsAPI codebase rt =
   projectListingEndpoint codebase
-    :<|> projectBranchListingEndpoint codebase
-    :<|> serveProjectsCodebaseServerAPI codebase rt
+    :<|> ( \projectName ->
+             projectBranchListingEndpoint codebase projectName
+               :<|> serveProjectsCodebaseServerAPI codebase rt projectName
+               :<|> ( serveProjectDiffTermsEndpoint codebase projectName
+                        :<|> serveProjectDiffTypesEndpoint codebase projectName
+                    )
+         )
 
 serveUnisonLocal ::
   BackendEnv ->

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

@@ -47,6 +47,7 @@ import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName)
 import Unison.Server.Doc (Doc)
 import Unison.Server.Orphans ()
 import Unison.Server.Syntax qualified as Syntax
+import Unison.Share.API.Projects (BranchName)
 import Unison.ShortHash (ShortHash)
 import Unison.Syntax.HashQualified qualified as HQ (parseText)
 import Unison.Syntax.Name qualified as Name
@@ -258,7 +259,9 @@ data SemanticSyntaxDiff
     SegmentChange (String, String) (Maybe Syntax.Element)
   | -- (shared segment) (fromAnnotation, toAnnotation)
     AnnotationChange String (Maybe Syntax.Element, Maybe Syntax.Element)
-  deriving (Eq, Show)
+  deriving (Eq, Show, Generic)
+
+deriving instance ToSchema SemanticSyntaxDiff
 
 instance ToJSON SemanticSyntaxDiff where
   toJSON = \case
@@ -299,7 +302,9 @@ instance ToJSON SemanticSyntaxDiff where
 data DisplayObjectDiff
   = DisplayObjectDiff (DisplayObject [SemanticSyntaxDiff] [SemanticSyntaxDiff])
   | MismatchedDisplayObjects (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) (DisplayObject Syntax.SyntaxText Syntax.SyntaxText)
-  deriving stock (Show, Eq)
+  deriving stock (Show, Eq, Generic)
+
+deriving instance ToSchema DisplayObjectDiff
 
 data UnisonRef
   = TypeRef UnisonHash
@@ -459,3 +464,79 @@ instance Docs.ToCapture (Capture "project-and-branch" ProjectBranchNameParam) wh
     DocCapture
       "project-and-branch"
       "The name of a project and branch e.g. `@unison%2Fbase%2Fmain` or `@unison%2Fbase%2F@runarorama%2Fmain`"
+
+data TermDiffResponse = TermDiffResponse
+  { project :: ProjectName,
+    oldBranch :: BranchName,
+    newBranch :: BranchName,
+    oldTerm :: TermDefinition,
+    newTerm :: TermDefinition,
+    diff :: DisplayObjectDiff
+  }
+  deriving (Eq, Show, Generic)
+
+deriving instance ToSchema TermDiffResponse
+
+instance Docs.ToSample TermDiffResponse where
+  toSamples _ = []
+
+instance ToJSON TermDiffResponse where
+  toJSON (TermDiffResponse {diff, project, oldBranch, newBranch, oldTerm, newTerm}) =
+    case diff of
+      DisplayObjectDiff dispDiff ->
+        object
+          [ "diff" .= dispDiff,
+            "diffKind" .= ("diff" :: Text),
+            "project" .= project,
+            "oldBranchRef" .= oldBranch,
+            "newBranchRef" .= newBranch,
+            "oldTerm" .= oldTerm,
+            "newTerm" .= newTerm
+          ]
+      MismatchedDisplayObjects {} ->
+        object
+          [ "diffKind" .= ("mismatched" :: Text),
+            "project" .= project,
+            "oldBranchRef" .= oldBranch,
+            "newBranchRef" .= newBranch,
+            "oldTerm" .= oldTerm,
+            "newTerm" .= newTerm
+          ]
+
+data TypeDiffResponse = TypeDiffResponse
+  { project :: ProjectName,
+    oldBranch :: BranchName,
+    newBranch :: BranchName,
+    oldType :: TypeDefinition,
+    newType :: TypeDefinition,
+    diff :: DisplayObjectDiff
+  }
+  deriving (Eq, Show, Generic)
+
+deriving instance ToSchema TypeDiffResponse
+
+instance Docs.ToSample TypeDiffResponse where
+  toSamples _ = []
+
+instance ToJSON TypeDiffResponse where
+  toJSON (TypeDiffResponse {diff, project, oldBranch, newBranch, oldType, newType}) =
+    case diff of
+      DisplayObjectDiff dispDiff ->
+        object
+          [ "diff" .= dispDiff,
+            "diffKind" .= ("diff" :: Text),
+            "project" .= project,
+            "oldBranchRef" .= oldBranch,
+            "newBranchRef" .= newBranch,
+            "oldType" .= oldType,
+            "newType" .= newType
+          ]
+      MismatchedDisplayObjects {} ->
+        object
+          [ "diffKind" .= ("mismatched" :: Text),
+            "project" .= project,
+            "oldBranchRef" .= oldBranch,
+            "newBranchRef" .= newBranch,
+            "oldType" .= oldType,
+            "newType" .= newType
+          ]

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

@@ -34,6 +34,7 @@ module Unison.Share.API.Projects
     ProjectBranchIds (..),
     NotFound (..),
     Unauthorized (..),
+    BranchName,
   )
 where