Merge pull request #5576 from unisonweb/cp/json-caching

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

@@ -9,7 +9,7 @@
 module Unison.Server.Doc where
 
 import Control.Monad
-import Data.Aeson (ToJSON)
+import Data.Aeson (ToJSON, FromJSON)
 import Data.Foldable
 import Data.Functor
 import Data.Map qualified as Map
@@ -91,21 +91,21 @@ data DocG specialForm
   | Column [(DocG specialForm)]
   | Group (DocG specialForm)
   deriving stock (Eq, Ord, Show, Generic, Functor, Foldable, Traversable)
-  deriving anyclass (ToJSON)
+  deriving anyclass (ToJSON, FromJSON)
 
 deriving instance (ToSchema specialForm) => ToSchema (DocG specialForm)
 
 type UnisonHash = Text
 
 data Ref a = Term a | Type a
   deriving stock (Eq, Ord, Show, Generic, Functor, Foldable, Traversable)
-  deriving anyclass (ToJSON)
+  deriving anyclass (ToJSON, FromJSON)
 
 instance (ToSchema a) => ToSchema (Ref a)
 
 data MediaSource = MediaSource {mediaSourceUrl :: Text, mediaSourceMimeType :: Maybe Text}
   deriving stock (Eq, Ord, Show, Generic)
-  deriving anyclass (ToJSON, ToSchema)
+  deriving anyclass (ToJSON, FromJSON, ToSchema)
 
 data RenderedSpecialForm
   = Source [SrcRefs]
@@ -125,7 +125,7 @@ data RenderedSpecialForm
   | Svg Text
   | RenderError (RenderError SyntaxText)
   deriving stock (Eq, Ord, Show, Generic)
-  deriving anyclass (ToJSON, ToSchema)
+  deriving anyclass (ToJSON, FromJSON, ToSchema)
 
 data EvaluatedSpecialForm v
   = ESource [(EvaluatedSrc v)]
@@ -151,7 +151,7 @@ data EvaluatedSpecialForm v
 -- `Src folded unfolded`
 data Src = Src SyntaxText SyntaxText
   deriving stock (Eq, Ord, Show, Generic)
-  deriving anyclass (ToJSON, ToSchema)
+  deriving anyclass (ToJSON, FromJSON, ToSchema)
 
 -- | Evaluate the doc, then render it.
 evalAndRenderDoc ::
@@ -448,7 +448,7 @@ evalDoc terms typeOf eval types tm =
 data RenderError trm
   = InvalidTerm trm
   deriving stock (Eq, Ord, Show, Generic)
-  deriving anyclass (ToJSON)
+  deriving anyclass (ToJSON, FromJSON)
 
 deriving anyclass instance (ToSchema trm) => ToSchema (RenderError trm)
 

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

@@ -329,10 +329,21 @@ instance ToCapture (Capture "namespace" Path.Path) where
       "E.g. base.List"
 
 instance ToJSON Path.Path where
-  toJSON p = Aeson.String (tShow p)
+  toJSON p = Aeson.String (Path.toText p)
+
+instance FromJSON Path.Path where
+  parseJSON = Aeson.withText "Path" \txt -> case Path.parsePath (Text.unpack txt) of
+    Left s -> fail (Text.unpack s)
+    Right p -> pure p
 
 instance ToJSON Path.Absolute where
-  toJSON p = Aeson.String (tShow p)
+  toJSON p = Aeson.String (Path.absToText p)
+
+instance FromJSON Path.Absolute where
+  parseJSON = Aeson.withText "Path" \txt -> case Path.parsePath' (Text.unpack txt) of
+    Left s -> fail (Text.unpack s)
+    Right (Path.AbsolutePath' p) -> pure p
+    Right (Path.RelativePath' _) -> fail "Expected an absolute path but received a relative path."
 
 instance ToSchema Path.Path where
   declareNamedSchema _ = declareNamedSchema (Proxy @Text)
@@ -428,6 +439,8 @@ instance ToSchema ProjectName
 
 deriving via Text instance ToJSON ProjectName
 
+deriving via Text instance FromJSON ProjectName
+
 deriving via Text instance Sqlite.FromField ProjectBranchName
 
 instance FromHttpApiData ProjectBranchName where
@@ -449,6 +462,8 @@ instance ToCapture (Capture "branch-name" ProjectBranchName) where
 
 deriving via Text instance ToJSON ProjectBranchName
 
+deriving via Text instance FromJSON ProjectBranchName
+
 -- CBOR encodings
 
 deriving via Text instance Serialise Hash32

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

@@ -98,6 +98,13 @@ instance ToJSON NamespaceDetails where
         "readme" .= readme
       ]
 
+instance FromJSON NamespaceDetails where
+  parseJSON = Aeson.withObject "NamespaceDetails" \obj -> do
+    fqn <- obj .: "fqn"
+    hash <- obj .: "hash"
+    readme <- obj .: "readme"
+    pure $ NamespaceDetails {..}
+
 deriving instance ToSchema NamespaceDetails
 
 -- | A hash qualified name, unlike HashQualified, the hash is required
@@ -168,6 +175,15 @@ instance ToJSON TypeDefinition where
         "typeDocs" .= typeDocs
       ]
 
+instance FromJSON TypeDefinition where
+  parseJSON = Aeson.withObject "TypeDefinition" \obj -> do
+    typeNames <- obj .: "typeNames"
+    bestTypeName <- obj .: "bestTypeName"
+    defnTypeTag <- obj .: "defnTypeTag"
+    typeDefinition <- obj .: "typeDefinition"
+    typeDocs <- obj .: "typeDocs"
+    pure $ TypeDefinition {..}
+
 deriving instance ToSchema TypeDefinition
 
 instance ToJSON TermDefinition where
@@ -181,6 +197,16 @@ instance ToJSON TermDefinition where
         "termDocs" .= termDocs
       ]
 
+instance FromJSON TermDefinition where
+  parseJSON = Aeson.withObject "TermDefinition" \obj -> do
+    termNames <- obj .: "termNames"
+    bestTermName <- obj .: "bestTermName"
+    defnTermTag <- obj .: "defnTermTag"
+    termDefinition <- obj .: "termDefinition"
+    signature <- obj .: "signature"
+    termDocs <- obj .: "termDocs"
+    pure $ TermDefinition {..}
+
 deriving instance ToSchema TermDefinition
 
 instance ToJSON DefinitionDisplayResults where
@@ -191,6 +217,13 @@ instance ToJSON DefinitionDisplayResults where
         "missingDefinitions" .= missingDefinitions
       ]
 
+instance FromJSON DefinitionDisplayResults where
+  parseJSON = Aeson.withObject "DefinitionDisplayResults" \obj -> do
+    termDefinitions <- obj .: "termDefinitions"
+    typeDefinitions <- obj .: "typeDefinitions"
+    missingDefinitions <- obj .: "missingDefinitions"
+    pure $ DefinitionDisplayResults {..}
+
 deriving instance ToSchema DefinitionDisplayResults
 
 data TermDefinitionDiff = TermDefinitionDiff
@@ -296,6 +329,25 @@ instance ToJSON SemanticSyntaxDiff where
           "toAnnotation" .= toAnnotation
         ]
 
+instance FromJSON SemanticSyntaxDiff where
+  parseJSON = Aeson.withObject "SemanticSyntaxDiff" \obj -> do
+    diffTag :: Text <- obj .: "diffTag"
+    case diffTag of
+      "old" -> Old <$> obj .: "elements"
+      "new" -> New <$> obj .: "elements"
+      "both" -> Both <$> obj .: "elements"
+      "segmentChange" -> do
+        fromSegment <- obj .: "fromSegment"
+        toSegment <- obj .: "toSegment"
+        annotation <- obj .: "annotation"
+        pure $ SegmentChange (fromSegment, toSegment) annotation
+      "annotationChange" -> do
+        segment <- obj .: "segment"
+        fromAnnotation <- obj .: "fromAnnotation"
+        toAnnotation <- obj .: "toAnnotation"
+        pure $ AnnotationChange segment (fromAnnotation, toAnnotation)
+      _ -> fail "Invalid diffTag"
+
 -- | A diff of the syntax of a term or type
 --
 -- It doesn't make sense to diff builtins with ABTs, so in that case we just provide the
@@ -504,6 +556,20 @@ instance ToJSON TermDiffResponse where
             "newTerm" .= newTerm
           ]
 
+instance FromJSON TermDiffResponse where
+  parseJSON = Aeson.withObject "TermDiffResponse" \obj -> do
+    diff <- DisplayObjectDiff <$> obj .: "diff"
+    diffKind :: Text <- obj .: "diffKind"
+    project <- obj .: "project"
+    oldBranch <- obj .: "oldBranchRef"
+    newBranch <- obj .: "newBranchRef"
+    oldTerm <- obj .: "oldTerm"
+    newTerm <- obj .: "newTerm"
+    case diffKind of
+      "diff" -> pure $ TermDiffResponse {..}
+      "mismatched" -> pure $ TermDiffResponse {..}
+      _ -> fail "Invalid diffKind"
+
 data TypeDiffResponse = TypeDiffResponse
   { project :: ProjectName,
     oldBranch :: ProjectBranchName,
@@ -542,5 +608,19 @@ instance ToJSON TypeDiffResponse where
             "newType" .= newType
           ]
 
+instance FromJSON TypeDiffResponse where
+  parseJSON = Aeson.withObject "TypeDiffResponse" \obj -> do
+    diff <- DisplayObjectDiff <$> obj .: "diff"
+    diffKind :: Text <- obj .: "diffKind"
+    project <- obj .: "project"
+    oldBranch <- obj .: "oldBranchRef"
+    newBranch <- obj .: "newBranchRef"
+    oldType <- obj .: "oldType"
+    newType <- obj .: "newType"
+    case diffKind of
+      "diff" -> pure $ TypeDiffResponse {..}
+      "mismatched" -> pure $ TypeDiffResponse {..}
+      _ -> fail "Invalid diffKind"
+
 -- | Servant utility for a query param that's required, providing a useful error message if it's missing.
 type RequiredQueryParam = Servant.QueryParam' '[Servant.Required, Servant.Strict]