github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-28 09:21:35 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #296 from github/proto-lens

Browse Source 
Switch to proto-lens
This commit is contained in:
Timothy Clem 2019-10-03 10:15:15 -07:00 committed by GitHub
commit 05edc308d0
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
22 changed files with 6992 additions and 1474 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -24,6 +24,7 @@ tmp/
*.hp
*.prof
*.pyc
/hie.yaml
/test.*
/*.html

14
Dockerfile
View File

@ -1,5 +1,10 @@
# Put protoc and twirp tooling in its own image
FROM golang:1.12-stretch AS protoc
FROM haskell:8.6 as haskell
RUN cabal new-update hackage.haskell.org,HEAD
RUN cabal new-install proto-lens-protoc
RUN which proto-lens-protoc
FROM golang:1.13-stretch AS protoc
RUN apt-get update && apt-get install -y unzip
ENV PROTOBUF_VERSION=3.7.1
RUN wget "https://github.com/protocolbuffers/protobuf/releases/download/v3.7.1/protoc-$PROTOBUF_VERSION-linux-x86_64.zip" && \
@ -7,10 +12,11 @@ RUN wget "https://github.com/protocolbuffers/protobuf/releases/download/v3.7.1/p
RUN go get github.com/golang/protobuf/proto && \
go get github.com/twitchtv/protogen/typemap && \
go get github.com/tclem/twirp-haskell/pkg/gen/haskell && \
go get github.com/tclem/twirp-haskell/protoc-gen-haskell
GO111MODULE=on go get github.com/tclem/proto-lens-jsonpb/protoc-gen-jsonpb_haskell@e4d10b77f57ee25beb759a33e63e2061420d3dc2
ENTRYPOINT ["/protobuf/bin/protoc", "-I/protobuf", "-I=/go/src/github.com/tclem/twirp-haskell"]
COPY --from=haskell /root/.cabal/bin/proto-lens-protoc /usr/local/bin/proto-lens-protoc
ENTRYPOINT ["/protobuf/bin/protoc", "-I/protobuf", "--plugin=protoc-gen-haskell=/usr/local/bin/proto-lens-protoc"]
# Build semantic
FROM haskell:8.6 as build

9
cabal.project
View File

@ -4,10 +4,5 @@ jobs: $ncpus
source-repository-package
type: git
location: https://github.com/joshvera/proto3-suite.git
tag: 83f3352f0c7c94ea091e6087f60692eda9991fae
source-repository-package
type: git
location: https://github.com/joshvera/proto3-wire.git
tag: 84664e22f01beb67870368f1f88ada5d0ad01f56
location: https://github.com/tclem/proto-lens-jsonpb
tag: e4d10b77f57ee25beb759a33e63e2061420d3dc2

3
proto/semantic.proto
View File

@ -1,10 +1,7 @@
syntax = "proto3";
import "pkg/gen/haskell/haskell.proto";
package github.semantic;
option (haskell.haskell_package) = "Semantic.Proto";
option ruby_package = "Semantic::Proto";
message PingRequest {

5
script/protoc
View File

@ -14,6 +14,7 @@ export PROJECT="github.com/github/semantic"
# Generate Haskell for semantic's protobuf types
docker run --rm --user $(id -u):$(id -g) -v $(pwd):/go/src/$PROJECT -w /go/src/$PROJECT \
semantic-protoc \
--proto_path=proto --haskell_out=src/Semantic/Proto \
semantic-protoc --proto_path=proto \
--haskell_out=./src \
--jsonpb_haskell_out=./src \
semantic.proto

9
semantic.cabal
View File

@ -71,8 +71,6 @@ common dependencies
, text ^>= 1.2.3.1
, these >= 0.7 && <1
, unix ^>= 2.7.2.2
, proto3-suite
, proto3-wire
, lingo >= 0.2.0.0
common executable-flags
@ -241,6 +239,9 @@ library
-- High-level flow & operational functionality (logging, stats, etc.)
, Semantic.Analysis
-- API
, Proto.Semantic
, Proto.Semantic_Fields
, Proto.Semantic_JSON
, Semantic.Api
, Semantic.Api.Bridge
, Semantic.Api.Diffs
@ -248,7 +249,6 @@ library
, Semantic.Api.Symbols
, Semantic.Api.Terms
, Semantic.Api.TOCSummaries
, Semantic.Proto.SemanticPB
, Semantic.AST
, Semantic.CLI
, Semantic.Config
@ -304,6 +304,9 @@ library
, prettyprinter ^>= 1.2.1
, pretty-show ^>= 1.9.5
, profunctors ^>= 5.3
, proto-lens ^>= 0.5.1.0
, proto-lens-jsonpb
, proto-lens-runtime ^>= 0.5.0.0
, reducers ^>= 3.12.3
, semantic-tags ^>= 0
, semigroupoids ^>= 5.3.2

8
src/Data/Graph.hs
View File

@ -21,9 +21,11 @@ import Algebra.Graph.Class (connect, overlay, vertex)
import qualified Algebra.Graph.Class as Class
import qualified Algebra.Graph.ToGraph as Class
import Control.Effect.State
import Control.Lens (view)
import Data.Aeson
import qualified Data.Set as Set
import Semantic.Proto.SemanticPB
import Proto.Semantic as P
import Proto.Semantic_Fields as P
-- | An algebraic graph with 'Ord', 'Semigroup', and 'Monoid' instances.
newtype Graph vertex = Graph { unGraph :: G.Graph vertex }
@ -100,8 +102,8 @@ instance Ord vertex => Ord (Graph vertex) where
class VertexTag vertex where
uniqueTag :: vertex -> Int
instance VertexTag DiffTreeVertex where uniqueTag = fromIntegral . diffVertexId
instance VertexTag TermVertex where uniqueTag = fromIntegral . vertexId
instance VertexTag DiffTreeVertex where uniqueTag = fromIntegral . view diffVertexId
instance VertexTag TermVertex where uniqueTag = fromIntegral . view vertexId
instance (Ord vertex, ToJSON vertex, VertexTag vertex) => ToJSON (Graph vertex) where
toJSON (Graph graph) = object ["vertices" .= G.vertexList graph, "edges" .= (Edge <$> G.edgeList graph)]

5553
src/Proto/Semantic.hs Normal file
View File

File diff suppressed because it is too large Load Diff

404
src/Proto/Semantic_Fields.hs Normal file
View File

@ -0,0 +1,404 @@
{- This file was auto-generated from semantic.proto by the proto-lens-protoc program. -}
{-# LANGUAGE ScopedTypeVariables, DataKinds, TypeFamilies,
UndecidableInstances, GeneralizedNewtypeDeriving,
MultiParamTypeClasses, FlexibleContexts, FlexibleInstances,
PatternSynonyms, MagicHash, NoImplicitPrelude, DataKinds,
BangPatterns, TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-unused-imports#-}
{-# OPTIONS_GHC -Wno-missing-export-lists #-} -- Manually added for semantic's project settings
{-# OPTIONS_GHC -fno-warn-duplicate-exports#-}
module Proto.Semantic_Fields where
import qualified Data.ProtoLens.Runtime.Prelude as Prelude
import qualified Data.ProtoLens.Runtime.Data.Int as Data.Int
import qualified Data.ProtoLens.Runtime.Data.Monoid as Data.Monoid
import qualified Data.ProtoLens.Runtime.Data.Word as Data.Word
import qualified Data.ProtoLens.Runtime.Data.ProtoLens
as Data.ProtoLens
import qualified
Data.ProtoLens.Runtime.Data.ProtoLens.Encoding.Bytes
as Data.ProtoLens.Encoding.Bytes
import qualified
Data.ProtoLens.Runtime.Data.ProtoLens.Encoding.Growing
as Data.ProtoLens.Encoding.Growing
import qualified
Data.ProtoLens.Runtime.Data.ProtoLens.Encoding.Parser.Unsafe
as Data.ProtoLens.Encoding.Parser.Unsafe
import qualified
Data.ProtoLens.Runtime.Data.ProtoLens.Encoding.Wire
as Data.ProtoLens.Encoding.Wire
import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Field
as Data.ProtoLens.Field
import qualified Data.ProtoLens.Runtime.Data.ProtoLens.Message.Enum
as Data.ProtoLens.Message.Enum
import qualified
Data.ProtoLens.Runtime.Data.ProtoLens.Service.Types
as Data.ProtoLens.Service.Types
import qualified Data.ProtoLens.Runtime.Lens.Family2
as Lens.Family2
import qualified Data.ProtoLens.Runtime.Lens.Family2.Unchecked
as Lens.Family2.Unchecked
import qualified Data.ProtoLens.Runtime.Data.Text as Data.Text
import qualified Data.ProtoLens.Runtime.Data.Map as Data.Map
import qualified Data.ProtoLens.Runtime.Data.ByteString
as Data.ByteString
import qualified Data.ProtoLens.Runtime.Data.ByteString.Char8
as Data.ByteString.Char8
import qualified Data.ProtoLens.Runtime.Data.Text.Encoding
as Data.Text.Encoding
import qualified Data.ProtoLens.Runtime.Data.Vector as Data.Vector
import qualified Data.ProtoLens.Runtime.Data.Vector.Generic
as Data.Vector.Generic
import qualified Data.ProtoLens.Runtime.Data.Vector.Unboxed
as Data.Vector.Unboxed
import qualified Data.ProtoLens.Runtime.Text.Read as Text.Read
after ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "after" a) =>
Lens.Family2.LensLike' f s a
after = Data.ProtoLens.Field.field @"after"
afterSpan ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "afterSpan" a) =>
Lens.Family2.LensLike' f s a
afterSpan = Data.ProtoLens.Field.field @"afterSpan"
afterTerm ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "afterTerm" a) =>
Lens.Family2.LensLike' f s a
afterTerm = Data.ProtoLens.Field.field @"afterTerm"
before ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "before" a) =>
Lens.Family2.LensLike' f s a
before = Data.ProtoLens.Field.field @"before"
beforeSpan ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "beforeSpan" a) =>
Lens.Family2.LensLike' f s a
beforeSpan = Data.ProtoLens.Field.field @"beforeSpan"
beforeTerm ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "beforeTerm" a) =>
Lens.Family2.LensLike' f s a
beforeTerm = Data.ProtoLens.Field.field @"beforeTerm"
blobOid ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "blobOid" a) =>
Lens.Family2.LensLike' f s a
blobOid = Data.ProtoLens.Field.field @"blobOid"
blobs ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "blobs" a) =>
Lens.Family2.LensLike' f s a
blobs = Data.ProtoLens.Field.field @"blobs"
category ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "category" a) =>
Lens.Family2.LensLike' f s a
category = Data.ProtoLens.Field.field @"category"
changeType ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "changeType" a) =>
Lens.Family2.LensLike' f s a
changeType = Data.ProtoLens.Field.field @"changeType"
changes ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "changes" a) =>
Lens.Family2.LensLike' f s a
changes = Data.ProtoLens.Field.field @"changes"
column ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "column" a) =>
Lens.Family2.LensLike' f s a
column = Data.ProtoLens.Field.field @"column"
content ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "content" a) =>
Lens.Family2.LensLike' f s a
content = Data.ProtoLens.Field.field @"content"
deleted ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "deleted" a) =>
Lens.Family2.LensLike' f s a
deleted = Data.ProtoLens.Field.field @"deleted"
diffVertexId ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "diffVertexId" a) =>
Lens.Family2.LensLike' f s a
diffVertexId = Data.ProtoLens.Field.field @"diffVertexId"
docs ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "docs" a) =>
Lens.Family2.LensLike' f s a
docs = Data.ProtoLens.Field.field @"docs"
docstring ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "docstring" a) =>
Lens.Family2.LensLike' f s a
docstring = Data.ProtoLens.Field.field @"docstring"
edges ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "edges" a) =>
Lens.Family2.LensLike' f s a
edges = Data.ProtoLens.Field.field @"edges"
end ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "end" a) =>
Lens.Family2.LensLike' f s a
end = Data.ProtoLens.Field.field @"end"
error ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "error" a) =>
Lens.Family2.LensLike' f s a
error = Data.ProtoLens.Field.field @"error"
errors ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "errors" a) =>
Lens.Family2.LensLike' f s a
errors = Data.ProtoLens.Field.field @"errors"
files ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "files" a) =>
Lens.Family2.LensLike' f s a
files = Data.ProtoLens.Field.field @"files"
hostname ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "hostname" a) =>
Lens.Family2.LensLike' f s a
hostname = Data.ProtoLens.Field.field @"hostname"
inserted ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "inserted" a) =>
Lens.Family2.LensLike' f s a
inserted = Data.ProtoLens.Field.field @"inserted"
kind ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "kind" a) =>
Lens.Family2.LensLike' f s a
kind = Data.ProtoLens.Field.field @"kind"
language ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "language" a) =>
Lens.Family2.LensLike' f s a
language = Data.ProtoLens.Field.field @"language"
line ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "line" a) =>
Lens.Family2.LensLike' f s a
line = Data.ProtoLens.Field.field @"line"
maybe'after ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'after" a) =>
Lens.Family2.LensLike' f s a
maybe'after = Data.ProtoLens.Field.field @"maybe'after"
maybe'afterSpan ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'afterSpan" a) =>
Lens.Family2.LensLike' f s a
maybe'afterSpan = Data.ProtoLens.Field.field @"maybe'afterSpan"
maybe'before ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'before" a) =>
Lens.Family2.LensLike' f s a
maybe'before = Data.ProtoLens.Field.field @"maybe'before"
maybe'beforeSpan ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'beforeSpan" a) =>
Lens.Family2.LensLike' f s a
maybe'beforeSpan = Data.ProtoLens.Field.field @"maybe'beforeSpan"
maybe'deleted ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'deleted" a) =>
Lens.Family2.LensLike' f s a
maybe'deleted = Data.ProtoLens.Field.field @"maybe'deleted"
maybe'diffTerm ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'diffTerm" a) =>
Lens.Family2.LensLike' f s a
maybe'diffTerm = Data.ProtoLens.Field.field @"maybe'diffTerm"
maybe'docs ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'docs" a) =>
Lens.Family2.LensLike' f s a
maybe'docs = Data.ProtoLens.Field.field @"maybe'docs"
maybe'end ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'end" a) =>
Lens.Family2.LensLike' f s a
maybe'end = Data.ProtoLens.Field.field @"maybe'end"
maybe'inserted ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'inserted" a) =>
Lens.Family2.LensLike' f s a
maybe'inserted = Data.ProtoLens.Field.field @"maybe'inserted"
maybe'merged ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'merged" a) =>
Lens.Family2.LensLike' f s a
maybe'merged = Data.ProtoLens.Field.field @"maybe'merged"
maybe'replaced ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'replaced" a) =>
Lens.Family2.LensLike' f s a
maybe'replaced = Data.ProtoLens.Field.field @"maybe'replaced"
maybe'span ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'span" a) =>
Lens.Family2.LensLike' f s a
maybe'span = Data.ProtoLens.Field.field @"maybe'span"
maybe'start ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'start" a) =>
Lens.Family2.LensLike' f s a
maybe'start = Data.ProtoLens.Field.field @"maybe'start"
merged ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "merged" a) =>
Lens.Family2.LensLike' f s a
merged = Data.ProtoLens.Field.field @"merged"
path ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "path" a) =>
Lens.Family2.LensLike' f s a
path = Data.ProtoLens.Field.field @"path"
replaced ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "replaced" a) =>
Lens.Family2.LensLike' f s a
replaced = Data.ProtoLens.Field.field @"replaced"
service ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "service" a) =>
Lens.Family2.LensLike' f s a
service = Data.ProtoLens.Field.field @"service"
sha ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "sha" a) =>
Lens.Family2.LensLike' f s a
sha = Data.ProtoLens.Field.field @"sha"
source ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "source" a) =>
Lens.Family2.LensLike' f s a
source = Data.ProtoLens.Field.field @"source"
span ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "span" a) =>
Lens.Family2.LensLike' f s a
span = Data.ProtoLens.Field.field @"span"
start ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "start" a) =>
Lens.Family2.LensLike' f s a
start = Data.ProtoLens.Field.field @"start"
status ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "status" a) =>
Lens.Family2.LensLike' f s a
status = Data.ProtoLens.Field.field @"status"
symbol ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "symbol" a) =>
Lens.Family2.LensLike' f s a
symbol = Data.ProtoLens.Field.field @"symbol"
symbols ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "symbols" a) =>
Lens.Family2.LensLike' f s a
symbols = Data.ProtoLens.Field.field @"symbols"
target ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "target" a) =>
Lens.Family2.LensLike' f s a
target = Data.ProtoLens.Field.field @"target"
term ::
forall f s a .
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "term" a) =>
Lens.Family2.LensLike' f s a
term = Data.ProtoLens.Field.field @"term"
timestamp ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "timestamp" a) =>
Lens.Family2.LensLike' f s a
timestamp = Data.ProtoLens.Field.field @"timestamp"
vec'blobs ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "vec'blobs" a) =>
Lens.Family2.LensLike' f s a
vec'blobs = Data.ProtoLens.Field.field @"vec'blobs"
vec'changes ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "vec'changes" a) =>
Lens.Family2.LensLike' f s a
vec'changes = Data.ProtoLens.Field.field @"vec'changes"
vec'edges ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "vec'edges" a) =>
Lens.Family2.LensLike' f s a
vec'edges = Data.ProtoLens.Field.field @"vec'edges"
vec'errors ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "vec'errors" a) =>
Lens.Family2.LensLike' f s a
vec'errors = Data.ProtoLens.Field.field @"vec'errors"
vec'files ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "vec'files" a) =>
Lens.Family2.LensLike' f s a
vec'files = Data.ProtoLens.Field.field @"vec'files"
vec'symbols ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "vec'symbols" a) =>
Lens.Family2.LensLike' f s a
vec'symbols = Data.ProtoLens.Field.field @"vec'symbols"
vec'vertices ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "vec'vertices" a) =>
Lens.Family2.LensLike' f s a
vec'vertices = Data.ProtoLens.Field.field @"vec'vertices"
vertexId ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "vertexId" a) =>
Lens.Family2.LensLike' f s a
vertexId = Data.ProtoLens.Field.field @"vertexId"
vertices ::
forall f s a .
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "vertices" a) =>
Lens.Family2.LensLike' f s a
vertices = Data.ProtoLens.Field.field @"vertices"

842
src/Proto/Semantic_JSON.hs Normal file
View File

@ -0,0 +1,842 @@
-- Code generated by protoc-gen-jsonpb_haskell 0.1.0, DO NOT EDIT.
{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports -Wno-missing-export-lists #-}
module Proto.Semantic_JSON where
import Prelude(($), (.), (<$>), pure, show, Maybe(..))
import Data.ProtoLens.Runtime.Lens.Family2 ((^.), (.~), (&))
import Data.Monoid (mconcat)
import Control.Monad (msum)
import Data.ProtoLens (defMessage)
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as E
import Data.ProtoLens.JSONPB as JSONPB
import qualified Data.Text as T
import Proto.Semantic as P
import Proto.Semantic_Fields as P
instance FromJSONPB PingRequest where
parseJSONPB = withObject "PingRequest" $ \obj -> do
service' <- obj .: "service"
pure $ defMessage
& P.service .~ service'
instance ToJSONPB PingRequest where
toJSONPB x = object
[ "service" .= (x^.service)
]
toEncodingPB x = pairs
[ "service" .= (x^.service)
]
instance FromJSON PingRequest where
parseJSON = parseJSONPB
instance ToJSON PingRequest where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB PingResponse where
parseJSONPB = withObject "PingResponse" $ \obj -> do
status' <- obj .: "status"
hostname' <- obj .: "hostname"
timestamp' <- obj .: "timestamp"
sha' <- obj .: "sha"
pure $ defMessage
& P.status .~ status'
& P.hostname .~ hostname'
& P.timestamp .~ timestamp'
& P.sha .~ sha'
instance ToJSONPB PingResponse where
toJSONPB x = object
[ "status" .= (x^.status)
, "hostname" .= (x^.hostname)
, "timestamp" .= (x^.timestamp)
, "sha" .= (x^.sha)
]
toEncodingPB x = pairs
[ "status" .= (x^.status)
, "hostname" .= (x^.hostname)
, "timestamp" .= (x^.timestamp)
, "sha" .= (x^.sha)
]
instance FromJSON PingResponse where
parseJSON = parseJSONPB
instance ToJSON PingResponse where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB ParseTreeRequest where
parseJSONPB = withObject "ParseTreeRequest" $ \obj -> do
blobs' <- obj .: "blobs"
pure $ defMessage
& P.blobs .~ blobs'
instance ToJSONPB ParseTreeRequest where
toJSONPB x = object
[ "blobs" .= (x^.blobs)
]
toEncodingPB x = pairs
[ "blobs" .= (x^.blobs)
]
instance FromJSON ParseTreeRequest where
parseJSON = parseJSONPB
instance ToJSON ParseTreeRequest where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB ParseTreeSymbolResponse where
parseJSONPB = withObject "ParseTreeSymbolResponse" $ \obj -> do
files' <- obj .: "files"
pure $ defMessage
& P.files .~ files'
instance ToJSONPB ParseTreeSymbolResponse where
toJSONPB x = object
[ "files" .= (x^.files)
]
toEncodingPB x = pairs
[ "files" .= (x^.files)
]
instance FromJSON ParseTreeSymbolResponse where
parseJSON = parseJSONPB
instance ToJSON ParseTreeSymbolResponse where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB ParseTreeGraphResponse where
parseJSONPB = withObject "ParseTreeGraphResponse" $ \obj -> do
files' <- obj .: "files"
pure $ defMessage
& P.files .~ files'
instance ToJSONPB ParseTreeGraphResponse where
toJSONPB x = object
[ "files" .= (x^.files)
]
toEncodingPB x = pairs
[ "files" .= (x^.files)
]
instance FromJSON ParseTreeGraphResponse where
parseJSON = parseJSONPB
instance ToJSON ParseTreeGraphResponse where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB ParseTreeFileGraph where
parseJSONPB = withObject "ParseTreeFileGraph" $ \obj -> do
path' <- obj .: "path"
language' <- obj .: "language"
vertices' <- obj .: "vertices"
edges' <- obj .: "edges"
errors' <- obj .: "errors"
pure $ defMessage
& P.path .~ path'
& P.language .~ language'
& P.vertices .~ vertices'
& P.edges .~ edges'
& P.errors .~ errors'
instance ToJSONPB ParseTreeFileGraph where
toJSONPB x = object
[ "path" .= (x^.path)
, "language" .= (x^.language)
, "vertices" .= (x^.vertices)
, "edges" .= (x^.edges)
, "errors" .= (x^.errors)
]
toEncodingPB x = pairs
[ "path" .= (x^.path)
, "language" .= (x^.language)
, "vertices" .= (x^.vertices)
, "edges" .= (x^.edges)
, "errors" .= (x^.errors)
]
instance FromJSON ParseTreeFileGraph where
parseJSON = parseJSONPB
instance ToJSON ParseTreeFileGraph where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB TermEdge where
parseJSONPB = withObject "TermEdge" $ \obj -> do
source' <- obj .: "source"
target' <- obj .: "target"
pure $ defMessage
& P.source .~ source'
& P.target .~ target'
instance ToJSONPB TermEdge where
toJSONPB x = object
[ "source" .= (x^.source)
, "target" .= (x^.target)
]
toEncodingPB x = pairs
[ "source" .= (x^.source)
, "target" .= (x^.target)
]
instance FromJSON TermEdge where
parseJSON = parseJSONPB
instance ToJSON TermEdge where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB TermVertex where
parseJSONPB = withObject "TermVertex" $ \obj -> do
vertexId' <- obj .: "vertexId"
term' <- obj .: "term"
span' <- obj A..:? "span"
pure $ defMessage
& P.vertexId .~ vertexId'
& P.term .~ term'
& P.maybe'span .~ span'
instance ToJSONPB TermVertex where
toJSONPB x = object
[ "vertexId" .= (x^.vertexId)
, "term" .= (x^.term)
, "span" .= (x^.maybe'span)
]
toEncodingPB x = pairs
[ "vertexId" .= (x^.vertexId)
, "term" .= (x^.term)
, "span" .= (x^.maybe'span)
]
instance FromJSON TermVertex where
parseJSON = parseJSONPB
instance ToJSON TermVertex where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB ParseError where
parseJSONPB = withObject "ParseError" $ \obj -> do
error' <- obj .: "error"
pure $ defMessage
& P.error .~ error'
instance ToJSONPB ParseError where
toJSONPB x = object
[ "error" .= (x^.error)
]
toEncodingPB x = pairs
[ "error" .= (x^.error)
]
instance FromJSON ParseError where
parseJSON = parseJSONPB
instance ToJSON ParseError where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB DiffTreeRequest where
parseJSONPB = withObject "DiffTreeRequest" $ \obj -> do
blobs' <- obj .: "blobs"
pure $ defMessage
& P.blobs .~ blobs'
instance ToJSONPB DiffTreeRequest where
toJSONPB x = object
[ "blobs" .= (x^.blobs)
]
toEncodingPB x = pairs
[ "blobs" .= (x^.blobs)
]
instance FromJSON DiffTreeRequest where
parseJSON = parseJSONPB
instance ToJSON DiffTreeRequest where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB DiffTreeTOCResponse where
parseJSONPB = withObject "DiffTreeTOCResponse" $ \obj -> do
files' <- obj .: "files"
pure $ defMessage
& P.files .~ files'
instance ToJSONPB DiffTreeTOCResponse where
toJSONPB x = object
[ "files" .= (x^.files)
]
toEncodingPB x = pairs
[ "files" .= (x^.files)
]
instance FromJSON DiffTreeTOCResponse where
parseJSON = parseJSONPB
instance ToJSON DiffTreeTOCResponse where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB TOCSummaryFile where
parseJSONPB = withObject "TOCSummaryFile" $ \obj -> do
path' <- obj .: "path"
language' <- obj .: "language"
changes' <- obj .: "changes"
errors' <- obj .: "errors"
pure $ defMessage
& P.path .~ path'
& P.language .~ language'
& P.changes .~ changes'
& P.errors .~ errors'
instance ToJSONPB TOCSummaryFile where
toJSONPB x = object
[ "path" .= (x^.path)
, "language" .= (x^.language)
, "changes" .= (x^.changes)
, "errors" .= (x^.errors)
]
toEncodingPB x = pairs
[ "path" .= (x^.path)
, "language" .= (x^.language)
, "changes" .= (x^.changes)
, "errors" .= (x^.errors)
]
instance FromJSON TOCSummaryFile where
parseJSON = parseJSONPB
instance ToJSON TOCSummaryFile where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB TOCSummaryChange where
parseJSONPB = withObject "TOCSummaryChange" $ \obj -> do
category' <- obj .: "category"
term' <- obj .: "term"
span' <- obj A..:? "span"
changeType' <- obj .: "changeType"
pure $ defMessage
& P.category .~ category'
& P.term .~ term'
& P.maybe'span .~ span'
& P.changeType .~ changeType'
instance ToJSONPB TOCSummaryChange where
toJSONPB x = object
[ "category" .= (x^.category)
, "term" .= (x^.term)
, "span" .= (x^.maybe'span)
, "changeType" .= (x^.changeType)
]
toEncodingPB x = pairs
[ "category" .= (x^.category)
, "term" .= (x^.term)
, "span" .= (x^.maybe'span)
, "changeType" .= (x^.changeType)
]
instance FromJSON TOCSummaryChange where
parseJSON = parseJSONPB
instance ToJSON TOCSummaryChange where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB TOCSummaryError where
parseJSONPB = withObject "TOCSummaryError" $ \obj -> do
error' <- obj .: "error"
span' <- obj A..:? "span"
pure $ defMessage
& P.error .~ error'
& P.maybe'span .~ span'
instance ToJSONPB TOCSummaryError where
toJSONPB x = object
[ "error" .= (x^.error)
, "span" .= (x^.maybe'span)
]
toEncodingPB x = pairs
[ "error" .= (x^.error)
, "span" .= (x^.maybe'span)
]
instance FromJSON TOCSummaryError where
parseJSON = parseJSONPB
instance ToJSON TOCSummaryError where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB DiffTreeGraphResponse where
parseJSONPB = withObject "DiffTreeGraphResponse" $ \obj -> do
files' <- obj .: "files"
pure $ defMessage
& P.files .~ files'
instance ToJSONPB DiffTreeGraphResponse where
toJSONPB x = object
[ "files" .= (x^.files)
]
toEncodingPB x = pairs
[ "files" .= (x^.files)
]
instance FromJSON DiffTreeGraphResponse where
parseJSON = parseJSONPB
instance ToJSON DiffTreeGraphResponse where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB DiffTreeFileGraph where
parseJSONPB = withObject "DiffTreeFileGraph" $ \obj -> do
path' <- obj .: "path"
language' <- obj .: "language"
vertices' <- obj .: "vertices"
edges' <- obj .: "edges"
errors' <- obj .: "errors"
pure $ defMessage
& P.path .~ path'
& P.language .~ language'
& P.vertices .~ vertices'
& P.edges .~ edges'
& P.errors .~ errors'
instance ToJSONPB DiffTreeFileGraph where
toJSONPB x = object
[ "path" .= (x^.path)
, "language" .= (x^.language)
, "vertices" .= (x^.vertices)
, "edges" .= (x^.edges)
, "errors" .= (x^.errors)
]
toEncodingPB x = pairs
[ "path" .= (x^.path)
, "language" .= (x^.language)
, "vertices" .= (x^.vertices)
, "edges" .= (x^.edges)
, "errors" .= (x^.errors)
]
instance FromJSON DiffTreeFileGraph where
parseJSON = parseJSONPB
instance ToJSON DiffTreeFileGraph where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB DiffTreeEdge where
parseJSONPB = withObject "DiffTreeEdge" $ \obj -> do
source' <- obj .: "source"
target' <- obj .: "target"
pure $ defMessage
& P.source .~ source'
& P.target .~ target'
instance ToJSONPB DiffTreeEdge where
toJSONPB x = object
[ "source" .= (x^.source)
, "target" .= (x^.target)
]
toEncodingPB x = pairs
[ "source" .= (x^.source)
, "target" .= (x^.target)
]
instance FromJSON DiffTreeEdge where
parseJSON = parseJSONPB
instance ToJSON DiffTreeEdge where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB DiffTreeVertex'DiffTerm where
parseJSONPB = A.withObject "DiffTreeVertex'DiffTerm" $ \obj -> mconcat
[
DiffTreeVertex'Deleted <$> parseField obj "deleted"
, DiffTreeVertex'Inserted <$> parseField obj "inserted"
, DiffTreeVertex'Replaced <$> parseField obj "replaced"
, DiffTreeVertex'Merged <$> parseField obj "merged"
]
instance ToJSONPB DiffTreeVertex'DiffTerm where
toJSONPB (DiffTreeVertex'Deleted x) = object [ "deleted" .= Just x ]
toJSONPB (DiffTreeVertex'Inserted x) = object [ "inserted" .= Just x ]
toJSONPB (DiffTreeVertex'Replaced x) = object [ "replaced" .= Just x ]
toJSONPB (DiffTreeVertex'Merged x) = object [ "merged" .= Just x ]
toEncodingPB (DiffTreeVertex'Deleted x) = pairs [ "deleted" .= Just x ]
toEncodingPB (DiffTreeVertex'Inserted x) = pairs [ "inserted" .= Just x ]
toEncodingPB (DiffTreeVertex'Replaced x) = pairs [ "replaced" .= Just x ]
toEncodingPB (DiffTreeVertex'Merged x) = pairs [ "merged" .= Just x ]
instance FromJSON DiffTreeVertex'DiffTerm where
parseJSON = parseJSONPB
instance ToJSON DiffTreeVertex'DiffTerm where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB DiffTreeVertex where
parseJSONPB = withObject "DiffTreeVertex" $ \obj -> do
diffVertexId' <- obj .: "diffVertexId"
diffTerm' <- obj A..:? "diffTerm"
pure $ defMessage
& P.diffVertexId .~ diffVertexId'
& P.maybe'diffTerm .~ diffTerm'
instance ToJSONPB DiffTreeVertex where
toJSONPB x = object
[ "diffVertexId" .= (x^.diffVertexId)
, "diffTerm" .= (x^.maybe'diffTerm)
]
toEncodingPB x = pairs
[ "diffVertexId" .= (x^.diffVertexId)
, "diffTerm" .= (x^.maybe'diffTerm)
]
instance FromJSON DiffTreeVertex where
parseJSON = parseJSONPB
instance ToJSON DiffTreeVertex where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB DeletedTerm where
parseJSONPB = withObject "DeletedTerm" $ \obj -> do
term' <- obj .: "term"
span' <- obj A..:? "span"
pure $ defMessage
& P.term .~ term'
& P.maybe'span .~ span'
instance ToJSONPB DeletedTerm where
toJSONPB x = object
[ "term" .= (x^.term)
, "span" .= (x^.maybe'span)
]
toEncodingPB x = pairs
[ "term" .= (x^.term)
, "span" .= (x^.maybe'span)
]
instance FromJSON DeletedTerm where
parseJSON = parseJSONPB
instance ToJSON DeletedTerm where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB InsertedTerm where
parseJSONPB = withObject "InsertedTerm" $ \obj -> do
term' <- obj .: "term"
span' <- obj A..:? "span"
pure $ defMessage
& P.term .~ term'
& P.maybe'span .~ span'
instance ToJSONPB InsertedTerm where
toJSONPB x = object
[ "term" .= (x^.term)
, "span" .= (x^.maybe'span)
]
toEncodingPB x = pairs
[ "term" .= (x^.term)
, "span" .= (x^.maybe'span)
]
instance FromJSON InsertedTerm where
parseJSON = parseJSONPB
instance ToJSON InsertedTerm where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB ReplacedTerm where
parseJSONPB = withObject "ReplacedTerm" $ \obj -> do
beforeTerm' <- obj .: "beforeTerm"
beforeSpan' <- obj A..:? "beforeSpan"
afterTerm' <- obj .: "afterTerm"
afterSpan' <- obj A..:? "afterSpan"
pure $ defMessage
& P.beforeTerm .~ beforeTerm'
& P.maybe'beforeSpan .~ beforeSpan'
& P.afterTerm .~ afterTerm'
& P.maybe'afterSpan .~ afterSpan'
instance ToJSONPB ReplacedTerm where
toJSONPB x = object
[ "beforeTerm" .= (x^.beforeTerm)
, "beforeSpan" .= (x^.maybe'beforeSpan)
, "afterTerm" .= (x^.afterTerm)
, "afterSpan" .= (x^.maybe'afterSpan)
]
toEncodingPB x = pairs
[ "beforeTerm" .= (x^.beforeTerm)
, "beforeSpan" .= (x^.maybe'beforeSpan)
, "afterTerm" .= (x^.afterTerm)
, "afterSpan" .= (x^.maybe'afterSpan)
]
instance FromJSON ReplacedTerm where
parseJSON = parseJSONPB
instance ToJSON ReplacedTerm where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB MergedTerm where
parseJSONPB = withObject "MergedTerm" $ \obj -> do
term' <- obj .: "term"
beforeSpan' <- obj A..:? "beforeSpan"
afterSpan' <- obj A..:? "afterSpan"
pure $ defMessage
& P.term .~ term'
& P.maybe'beforeSpan .~ beforeSpan'
& P.maybe'afterSpan .~ afterSpan'
instance ToJSONPB MergedTerm where
toJSONPB x = object
[ "term" .= (x^.term)
, "beforeSpan" .= (x^.maybe'beforeSpan)
, "afterSpan" .= (x^.maybe'afterSpan)
]
toEncodingPB x = pairs
[ "term" .= (x^.term)
, "beforeSpan" .= (x^.maybe'beforeSpan)
, "afterSpan" .= (x^.maybe'afterSpan)
]
instance FromJSON MergedTerm where
parseJSON = parseJSONPB
instance ToJSON MergedTerm where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB Blob where
parseJSONPB = withObject "Blob" $ \obj -> do
content' <- obj .: "content"
path' <- obj .: "path"
language' <- obj .: "language"
pure $ defMessage
& P.content .~ content'
& P.path .~ path'
& P.language .~ language'
instance ToJSONPB Blob where
toJSONPB x = object
[ "content" .= (x^.content)
, "path" .= (x^.path)
, "language" .= (x^.language)
]
toEncodingPB x = pairs
[ "content" .= (x^.content)
, "path" .= (x^.path)
, "language" .= (x^.language)
]
instance FromJSON Blob where
parseJSON = parseJSONPB
instance ToJSON Blob where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB BlobPair where
parseJSONPB = withObject "BlobPair" $ \obj -> do
before' <- obj A..:? "before"
after' <- obj A..:? "after"
pure $ defMessage
& P.maybe'before .~ before'
& P.maybe'after .~ after'
instance ToJSONPB BlobPair where
toJSONPB x = object
[ "before" .= (x^.maybe'before)
, "after" .= (x^.maybe'after)
]
toEncodingPB x = pairs
[ "before" .= (x^.maybe'before)
, "after" .= (x^.maybe'after)
]
instance FromJSON BlobPair where
parseJSON = parseJSONPB
instance ToJSON BlobPair where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB File where
parseJSONPB = withObject "File" $ \obj -> do
path' <- obj .: "path"
language' <- obj .: "language"
symbols' <- obj .: "symbols"
errors' <- obj .: "errors"
blobOid' <- obj .: "blobOid"
pure $ defMessage
& P.path .~ path'
& P.language .~ language'
& P.symbols .~ symbols'
& P.errors .~ errors'
& P.blobOid .~ blobOid'
instance ToJSONPB File where
toJSONPB x = object
[ "path" .= (x^.path)
, "language" .= (x^.language)
, "symbols" .= (x^.symbols)
, "errors" .= (x^.errors)
, "blobOid" .= (x^.blobOid)
]
toEncodingPB x = pairs
[ "path" .= (x^.path)
, "language" .= (x^.language)
, "symbols" .= (x^.symbols)
, "errors" .= (x^.errors)
, "blobOid" .= (x^.blobOid)
]
instance FromJSON File where
parseJSON = parseJSONPB
instance ToJSON File where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB Symbol where
parseJSONPB = withObject "Symbol" $ \obj -> do
symbol' <- obj .: "symbol"
kind' <- obj .: "kind"
line' <- obj .: "line"
span' <- obj A..:? "span"
docs' <- obj A..:? "docs"
pure $ defMessage
& P.symbol .~ symbol'
& P.kind .~ kind'
& P.line .~ line'
& P.maybe'span .~ span'
& P.maybe'docs .~ docs'
instance ToJSONPB Symbol where
toJSONPB x = object
[ "symbol" .= (x^.symbol)
, "kind" .= (x^.kind)
, "line" .= (x^.line)
, "span" .= (x^.maybe'span)
, "docs" .= (x^.maybe'docs)
]
toEncodingPB x = pairs
[ "symbol" .= (x^.symbol)
, "kind" .= (x^.kind)
, "line" .= (x^.line)
, "span" .= (x^.maybe'span)
, "docs" .= (x^.maybe'docs)
]
instance FromJSON Symbol where
parseJSON = parseJSONPB
instance ToJSON Symbol where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB Docstring where
parseJSONPB = withObject "Docstring" $ \obj -> do
docstring' <- obj .: "docstring"
pure $ defMessage
& P.docstring .~ docstring'
instance ToJSONPB Docstring where
toJSONPB x = object
[ "docstring" .= (x^.docstring)
]
toEncodingPB x = pairs
[ "docstring" .= (x^.docstring)
]
instance FromJSON Docstring where
parseJSON = parseJSONPB
instance ToJSON Docstring where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB Position where
parseJSONPB = withObject "Position" $ \obj -> do
line' <- obj .: "line"
column' <- obj .: "column"
pure $ defMessage
& P.line .~ line'
& P.column .~ column'
instance ToJSONPB Position where
toJSONPB x = object
[ "line" .= (x^.line)
, "column" .= (x^.column)
]
toEncodingPB x = pairs
[ "line" .= (x^.line)
, "column" .= (x^.column)
]
instance FromJSON Position where
parseJSON = parseJSONPB
instance ToJSON Position where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB Span where
parseJSONPB = withObject "Span" $ \obj -> do
start' <- obj A..:? "start"
end' <- obj A..:? "end"
pure $ defMessage
& P.maybe'start .~ start'
& P.maybe'end .~ end'
instance ToJSONPB Span where
toJSONPB x = object
[ "start" .= (x^.maybe'start)
, "end" .= (x^.maybe'end)
]
toEncodingPB x = pairs
[ "start" .= (x^.maybe'start)
, "end" .= (x^.maybe'end)
]
instance FromJSON Span where
parseJSON = parseJSONPB
instance ToJSON Span where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB ChangeType where
parseJSONPB (JSONPB.String "NONE") = pure NONE
parseJSONPB (JSONPB.String "ADDED") = pure ADDED
parseJSONPB (JSONPB.String "REMOVED") = pure REMOVED
parseJSONPB (JSONPB.String "MODIFIED") = pure MODIFIED
parseJSONPB x = typeMismatch "ChangeType" x
instance ToJSONPB ChangeType where
toJSONPB x _ = A.String . T.toUpper . T.pack $ show x
toEncodingPB x _ = E.text . T.toUpper . T.pack $ show x
instance FromJSON ChangeType where
parseJSON = parseJSONPB
instance ToJSON ChangeType where
toJSON = toAesonValue
toEncoding = toAesonEncoding

56
src/Rendering/Graph.hs
View File

@ -12,14 +12,17 @@ import Control.Effect.Fresh
import Control.Effect.Pure
import Control.Effect.Reader
import Control.Effect.State
import Control.Lens
import Data.Diff
import Data.Graph
import Data.Patch
import Data.ProtoLens (defMessage)
import Data.String (IsString (..))
import Data.Term
import Prologue
import Semantic.Api.Bridge
import Semantic.Proto.SemanticPB
import Proto.Semantic as P
import Proto.Semantic_Fields as P
import Source.Loc as Loc
import qualified Data.Text as T
@ -39,23 +42,24 @@ runGraph = run . runFresh' . runReader mempty
-- | GraphViz styling for terms
termStyle :: (IsString string, Monoid string) => String -> Style TermVertex string
termStyle name = (defaultStyle (fromString . show . vertexId))
termStyle name = (defaultStyle (fromString . show . view vertexId))
{ graphName = fromString (quote name)
, vertexAttributes = vertexAttributes }
where quote a = "\"" <> a <> "\""
vertexAttributes TermVertex{..} = ["label" := fromString name]
vertexAttributes v = ["label" := fromString (T.unpack (v^.term))]
-- | Graphviz styling for diffs
diffStyle :: (IsString string, Monoid string) => String -> Style DiffTreeVertex string
diffStyle name = (defaultStyle (fromString . show . diffVertexId))
diffStyle name = (defaultStyle (fromString . show . view diffVertexId))
{ graphName = fromString (quote name)
, vertexAttributes = vertexAttributes }
where quote a = "\"" <> a <> "\""
vertexAttributes (DiffTreeVertex _ (Just (Deleted (Just DeletedTerm{..})))) = [ "label" := fromString (T.unpack term), "color" := "red" ]
vertexAttributes (DiffTreeVertex _ (Just (Inserted (Just InsertedTerm{..})))) = [ "label" := fromString (T.unpack term), "color" := "green" ]
vertexAttributes (DiffTreeVertex _ (Just (Replaced (Just ReplacedTerm{..})))) = [ "label" := "Replacement", "color" := "orange", "style" := "dashed" ]
vertexAttributes (DiffTreeVertex _ (Just (Merged (Just MergedTerm{..})))) = [ "label" := fromString (T.unpack term) ]
vertexAttributes _ = []
vertexAttributes v = case v^.maybe'diffTerm of
Just (DiffTreeVertex'Deleted x) -> [ "label" := fromString (T.unpack (x^.term)), "color" := "red" ]
Just (DiffTreeVertex'Inserted x) -> [ "label" := fromString (T.unpack (x^.term)), "color" := "green" ]
Just (DiffTreeVertex'Replaced _) -> [ "label" := "Replacement", "color" := "orange", "style" := "dashed" ]
Just (DiffTreeVertex'Merged x) -> [ "label" := fromString (T.unpack (x^.term)) ]
_ -> []
class ToTreeGraph vertex t | t -> vertex where
toTreeGraph :: (Member Fresh sig, Member (Reader (Graph vertex)) sig, Carrier sig m) => t (m (Graph vertex)) -> m (Graph vertex)
@ -75,23 +79,39 @@ instance (ConstructorName syntax, Foldable syntax) =>
termAlgebra (In ann syntax) = do
i <- fresh
parent <- ask
let root = vertex $ TermVertex (fromIntegral i) (T.pack (constructorName syntax)) (converting #? Loc.span ann)
let root = vertex $ defMessage
& P.vertexId .~ fromIntegral i
& P.term .~ T.pack (constructorName syntax)
& P.maybe'span .~ (converting #? Loc.span ann)
subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax
pure (parent `connect` root `overlay` subGraph)
instance (ConstructorName syntax, Foldable syntax) =>
ToTreeGraph DiffTreeVertex (DiffF syntax Loc Loc) where
toTreeGraph d = case d of
Merge t@(In (a1, a2) syntax) -> diffAlgebra t (Merged (Just (MergedTerm (T.pack (constructorName syntax)) (ann a1) (ann a2))))
Patch (Delete t1@(In a1 syntax)) -> diffAlgebra t1 (Deleted (Just (DeletedTerm (T.pack (constructorName syntax)) (ann a1))))
Patch (Insert t2@(In a2 syntax)) -> diffAlgebra t2 (Inserted (Just (InsertedTerm (T.pack (constructorName syntax)) (ann a2))))
Merge t@(In (a1, a2) syntax) -> diffAlgebra t . DiffTreeVertex'Merged $ defMessage
& P.term .~ T.pack (constructorName syntax)
& P.maybe'beforeSpan .~ ann a1
& P.maybe'afterSpan .~ ann a2
Patch (Delete t1@(In a1 syntax)) -> diffAlgebra t1 . DiffTreeVertex'Deleted $ defMessage
& P.term .~ T.pack (constructorName syntax)
& P.maybe'span .~ ann a1
Patch (Insert t2@(In a2 syntax)) -> diffAlgebra t2 . DiffTreeVertex'Inserted $ defMessage
& P.term .~ T.pack (constructorName syntax)
& P.maybe'span .~ ann a2
Patch (Replace t1@(In a1 syntax1) t2@(In a2 syntax2)) -> do
i <- fresh
parent <- ask
let (beforeName, beforeSpan) = (T.pack (constructorName syntax1), ann a1)
let (afterName, afterSpan) = (T.pack (constructorName syntax2), ann a2)
let replace = vertex (DiffTreeVertex (fromIntegral i) (Just (Replaced (Just (ReplacedTerm beforeName beforeSpan afterName afterSpan)))))
graph <- local (const replace) (overlay <$> diffAlgebra t1 (Deleted (Just (DeletedTerm beforeName beforeSpan))) <*> diffAlgebra t2 (Inserted (Just (InsertedTerm afterName afterSpan))))
let replace = vertex $ defMessage
& P.diffVertexId .~ fromIntegral i
& P.maybe'replaced ?~ (defMessage
& P.beforeTerm .~ beforeName
& P.maybe'beforeSpan .~ beforeSpan
& P.afterTerm .~ afterName
& P.maybe'afterSpan .~ afterSpan)
graph <- local (const replace) (overlay <$> diffAlgebra t1 (DiffTreeVertex'Deleted (defMessage & P.term .~ beforeName & P.maybe'span .~ beforeSpan)) <*> diffAlgebra t2 (DiffTreeVertex'Inserted (defMessage & P.term .~ afterName & P.maybe'span .~ afterSpan)))
pure (parent `connect` replace `overlay` graph)
where
ann a = converting #? Loc.span a
@ -100,10 +120,12 @@ instance (ConstructorName syntax, Foldable syntax) =>
, Member Fresh sig
, Member (Reader (Graph DiffTreeVertex)) sig
, Carrier sig m
) => f (m (Graph DiffTreeVertex)) -> DiffTreeVertexDiffTerm -> m (Graph DiffTreeVertex)
) => f (m (Graph DiffTreeVertex)) -> DiffTreeVertex'DiffTerm -> m (Graph DiffTreeVertex)
diffAlgebra syntax a = do
i <- fresh
parent <- ask
let root = vertex (DiffTreeVertex (fromIntegral i) (Just a))
let root = vertex $ defMessage
& P.diffVertexId .~ fromIntegral i
& P.maybe'diffTerm ?~ a
subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax
pure (parent `connect` root `overlay` subGraph)

2
src/Semantic/Api.hs
View File

@ -11,4 +11,4 @@ import Semantic.Api.Diffs as DiffsAPI
import Semantic.Api.Symbols as SymbolsAPI
import Semantic.Api.Terms as TermsAPI
import Semantic.Api.TOCSummaries as TOCSummariesAPI
import Semantic.Proto.SemanticPB as Types
import Proto.Semantic as Types

31
src/Semantic/Api/Bridge.hs
View File

@ -8,9 +8,11 @@ module Semantic.Api.Bridge
import Control.Lens
import qualified Data.Blob as Data
import qualified Data.Language as Data
import Data.ProtoLens (defMessage)
import qualified Data.Text as T
import qualified Semantic.Api.LegacyTypes as Legacy
import qualified Semantic.Proto.SemanticPB as API
import qualified Proto.Semantic as API
import Proto.Semantic_Fields as P
import Source.Source (fromText, toText)
import qualified Source.Span as Source
@ -50,13 +52,13 @@ instance APIBridge Legacy.Position Source.Pos where
instance APIBridge API.Position Source.Pos where
bridging = iso fromAPI toAPI where
toAPI Source.Pos{..} = API.Position (fromIntegral line) (fromIntegral column)
fromAPI API.Position{..} = Source.Pos (fromIntegral line) (fromIntegral column)
toAPI Source.Pos{..} = defMessage & P.line .~ fromIntegral line & P.column .~ fromIntegral column
fromAPI position = Source.Pos (fromIntegral (position^.line)) (fromIntegral (position^.column))
instance APIConvert API.Span Source.Span where
converting = prism' toAPI fromAPI where
toAPI Source.Span{..} = API.Span (bridging #? start) (bridging #? end)
fromAPI API.Span{..} = Source.Span <$> (start >>= preview bridging) <*> (end >>= preview bridging)
toAPI Source.Span{..} = defMessage & P.maybe'start .~ (bridging #? start) & P.maybe'end .~ (bridging #? end)
fromAPI span = Source.Span <$> (span^.maybe'start >>= preview bridging) <*> (span^.maybe'end >>= preview bridging)
instance APIConvert Legacy.Span Source.Span where
converting = prism' toAPI fromAPI where
@ -68,18 +70,19 @@ instance APIBridge T.Text Data.Language where
instance APIBridge API.Blob Data.Blob where
bridging = iso apiBlobToBlob blobToApiBlob where
blobToApiBlob b = API.Blob (toText (Data.blobSource b)) (T.pack (Data.blobPath b)) (bridging # Data.blobLanguage b)
apiBlobToBlob API.Blob{..} = Data.makeBlob (fromText content) (T.unpack path) (language ^. bridging) mempty
blobToApiBlob b = defMessage & P.content .~ toText (Data.blobSource b) & P.path .~ T.pack (Data.blobPath b) & P.language .~ (bridging # Data.blobLanguage b)
apiBlobToBlob blob = Data.makeBlob (fromText (blob^.content)) (T.unpack (blob^.path)) (blob^.(language . bridging)) mempty
instance APIConvert API.BlobPair Data.BlobPair where
converting = prism' blobPairToApiBlobPair apiBlobPairToBlobPair where
apiBlobPairToBlobPair (API.BlobPair (Just before) (Just after)) = Just $ Data.Diffing (before^.bridging) (after^.bridging)
apiBlobPairToBlobPair (API.BlobPair (Just before) Nothing) = Just $ Data.Deleting (before^.bridging)
apiBlobPairToBlobPair (API.BlobPair Nothing (Just after)) = Just $ Data.Inserting (after^.bridging)
apiBlobPairToBlobPair _ = Nothing
apiBlobPairToBlobPair blobPair = case (blobPair^.maybe'before, blobPair^.maybe'after) of
(Just before, Just after) -> Just $ Data.Diffing (before^.bridging) (after^.bridging)
(Just before, Nothing) -> Just $ Data.Deleting (before^.bridging)
(Nothing, Just after) -> Just $ Data.Inserting (after^.bridging)
_ -> Nothing
blobPairToApiBlobPair (Data.Diffing before after) = API.BlobPair (bridging #? before) (bridging #? after)
blobPairToApiBlobPair (Data.Inserting after) = API.BlobPair Nothing (bridging #? after)
blobPairToApiBlobPair (Data.Deleting before) = API.BlobPair (bridging #? before) Nothing
blobPairToApiBlobPair (Data.Diffing before after) = defMessage & P.maybe'before .~ (bridging #? before) & P.maybe'after .~ (bridging #? after)
blobPairToApiBlobPair (Data.Inserting after) = defMessage & P.maybe'before .~ Nothing & P.maybe'after .~ (bridging #? after)
blobPairToApiBlobPair (Data.Deleting before) = defMessage & P.maybe'before .~ (bridging #? before) & P.maybe'after .~ Nothing

55
src/Semantic/Api/Diffs.hs
View File

@ -27,20 +27,22 @@ import Data.ByteString.Builder
import Data.Graph
import Data.JSON.Fields
import Data.Language
import Data.ProtoLens (defMessage)
import Data.Term
import qualified Data.Text as T
import qualified Data.Vector as V
import Diffing.Algorithm (Diffable)
import Diffing.Interpreter (DiffTerms(..))
import Parsing.Parser
import Prologue
import Proto.Semantic as P hiding (Blob, BlobPair)
import Proto.Semantic_Fields as P
import Proto.Semantic_JSON()
import Rendering.Graph
import Rendering.JSON hiding (JSON)
import qualified Rendering.JSON
import Rendering.TOC
import Semantic.Api.Bridge
import Semantic.Config
import Semantic.Proto.SemanticPB hiding (Blob, BlobPair)
import Semantic.Task as Task
import Semantic.Telemetry as Stat
import Serializing.Format hiding (JSON)
@ -69,12 +71,19 @@ jsonError :: Applicative m => BlobPair -> SomeException -> m (Rendering.JSON.JSO
jsonError blobPair (SomeException e) = pure $ renderJSONDiffError blobPair (show e)
diffGraph :: (Traversable t, DiffEffects sig m) => t BlobPair -> m DiffTreeGraphResponse
diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor blobs go
diffGraph blobs = do
graph <- distributeFor blobs go
pure $ defMessage & P.files .~ toList graph
where
go :: DiffEffects sig m => BlobPair -> m DiffTreeFileGraph
go blobPair = diffWith jsonGraphDiffParsers (pure . jsonGraphDiff blobPair) blobPair
`catchError` \(SomeException e) ->
pure (DiffTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))]))
pure $ defMessage
& P.path .~ path
& P.language .~ lang
& P.vertices .~ mempty
& P.edges .~ mempty
& P.errors .~ [defMessage & P.error .~ T.pack (show e)]
where
path = T.pack $ pathForBlobPair blobPair
lang = bridging # languageForBlobPair blobPair
@ -101,10 +110,15 @@ class DiffTerms term => JSONGraphDiff term where
instance (ConstructorName syntax, Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => JSONGraphDiff (Term syntax) where
jsonGraphDiff blobPair diff
= let graph = renderTreeGraph diff
toEdge (Edge (a, b)) = DiffTreeEdge (diffVertexId a) (diffVertexId b)
in DiffTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty where
path = T.pack $ pathForBlobPair blobPair
lang = bridging # languageForBlobPair blobPair
toEdge (Edge (a, b)) = defMessage & P.source .~ a^.diffVertexId & P.target .~ b^.diffVertexId
path = T.pack $ pathForBlobPair blobPair
lang = bridging # languageForBlobPair blobPair
in defMessage
& P.path .~ path
& P.language .~ lang
& P.vertices .~ vertexList graph
& P.edges .~ fmap toEdge (edgeList graph)
& P.errors .~ mempty
jsonTreeDiffParsers :: Map Language (SomeParser JSONTreeDiff Loc)
@ -158,22 +172,29 @@ class DiffTerms term => SummarizeDiff term where
instance (Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Traversable syntax) => SummarizeDiff (Term syntax) where
decorateTerm = decoratorWithAlgebra . declarationAlgebra
summarizeDiff blobPair diff = foldr go (TOCSummaryFile path lang mempty mempty) (diffTOC diff)
summarizeDiff blobPair diff = foldr go (defMessage & P.path .~ path & P.language .~ lang) (diffTOC diff)
where
path = T.pack $ pathKeyForBlobPair blobPair
lang = bridging # languageForBlobPair blobPair
toChangeType = \case
"added" -> Added
"modified" -> Modified
"removed" -> Removed
_ -> None
"added" -> ADDED
"modified" -> MODIFIED
"removed" -> REMOVED
_ -> NONE
go :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile
go TOCSummary{..} TOCSummaryFile{..}
= TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (converting #? summarySpan) (toChangeType summaryChangeType)) changes) errors
go ErrorSummary{..} TOCSummaryFile{..}
= TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (converting #? errorSpan)) errors)
go TOCSummary{..} file = defMessage
& P.path .~ file^.P.path
& P.language .~ file^.P.language
& P.changes .~ (defMessage & P.category .~ summaryCategoryName & P.term .~ summaryTermName & P.maybe'span .~ (converting #? summarySpan) & P.changeType .~ toChangeType summaryChangeType) : file^.P.changes
& P.errors .~ file^.P.errors
go ErrorSummary{..} file = defMessage
& P.path .~ file^.P.path
& P.language .~ file^.P.language
& P.changes .~ file^.P.changes
& P.errors .~ (defMessage & P.error .~ errorText & P.maybe'span .~ converting #? errorSpan) : file^.P.errors
-- | Parse a 'BlobPair' using one of the provided parsers, diff the resulting terms, and run an action on the abstracted diff.

44
src/Semantic/Api/Symbols.hs
View File

@ -13,16 +13,18 @@ import Control.Lens
import Data.Blob hiding (File (..))
import Data.ByteString.Builder
import Data.Language
import Data.ProtoLens (defMessage)
import Data.Term
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Text (pack)
import qualified Data.Text as T
import qualified Language.Python as Python
import qualified Parsing.Parser as Parser
import Prologue
import Proto.Semantic as P hiding (Blob, BlobPair)
import Proto.Semantic_Fields as P
import Proto.Semantic_JSON ()
import Semantic.Api.Bridge
import qualified Semantic.Api.LegacyTypes as Legacy
import Semantic.Proto.SemanticPB hiding (Blob)
import Semantic.Config
import Semantic.Task
import Serializing.Format (Format)
@ -63,7 +65,9 @@ parseSymbolsBuilder :: (Member Distribute sig, Member (Error SomeException) sig,
parseSymbolsBuilder format blobs = parseSymbols blobs >>= serialize format
parseSymbols :: (Member Distribute sig, Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m, Traversable t) => t Blob -> m ParseTreeSymbolResponse
parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs go
parseSymbols blobs = do
terms <- distributeFor blobs go
pure $ defMessage & P.files .~ toList terms
where
go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m File
go blob@Blob{..} = catching $ asks toTagsParsers >>= \ p -> parseWith p (pure . renderToSymbols) blob
@ -71,27 +75,35 @@ parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distribut
catching m = m `catchError` (\(SomeException e) -> pure $ errorFile (show e))
blobLanguage' = blobLanguage blob
blobPath' = pack $ blobPath blob
errorFile e = File blobPath' (bridging # blobLanguage') mempty (V.fromList [ParseError (T.pack e)]) blobOid
errorFile e = defMessage
& P.path .~ blobPath'
& P.language .~ (bridging # blobLanguage')
& P.symbols .~ mempty
& P.errors .~ [defMessage & P.error .~ T.pack e]
& P.blobOid .~ blobOid
renderToSymbols :: ToTags t => t Loc -> File
renderToSymbols term = tagsToFile (tags (blobLanguage blob) symbolsToSummarize blobSource term)
tagsToFile :: [Tag] -> File
tagsToFile tags = File blobPath' (bridging # blobLanguage') (V.fromList (fmap tagToSymbol tags)) mempty blobOid
tagsToFile tags = defMessage
& P.path .~ blobPath'
& P.language .~ (bridging # blobLanguage')
& P.symbols .~ fmap tagToSymbol tags
& P.errors .~ mempty
& P.blobOid .~ blobOid
tagToSymbol :: Tag -> Symbol
tagToSymbol Tag{..} = defMessage
& P.symbol .~ name
& P.kind .~ pack (show kind)
& P.line .~ line
& P.maybe'span .~ converting #? span
& P.maybe'docs .~ fmap (flip (set P.docstring) defMessage) docs
symbolsToSummarize :: [Text]
symbolsToSummarize = ["Function", "Method", "Class", "Module", "Call", "Send"]
tagToSymbol :: Tag -> Symbol
tagToSymbol Tag{..} = Symbol
{ symbol = name
, kind = pack (show kind)
, line = line
, span = converting #? span
, docs = fmap Docstring docs
}
class ToTags t where
tags :: Language -> [Text] -> Source -> t Loc -> [Tag]

19
src/Semantic/Api/TOCSummaries.hs
View File

@ -6,13 +6,14 @@ import Data.Aeson
import Data.Blob
import Data.ByteString.Builder
import qualified Data.Map.Monoidal as Map
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.ProtoLens (defMessage)
import Data.Semilattice.Lower
import qualified Data.Text as T
import Proto.Semantic as P hiding (Blob, BlobPair)
import Proto.Semantic_Fields as P
import Rendering.TOC
import Semantic.Api.Diffs
import Semantic.Api.Bridge
import Semantic.Proto.SemanticPB hiding (Blob, BlobPair)
import Semantic.Api.Diffs
import Semantic.Task as Task
import Serializing.Format
@ -31,11 +32,17 @@ legacyDiffSummary = distributeFoldMap go
diffSummary :: DiffEffects sig m => [BlobPair] -> m DiffTreeTOCResponse
diffSummary blobs = DiffTreeTOCResponse . V.fromList <$> distributeFor blobs go
diffSummary blobs = do
diff <- distributeFor blobs go
pure $ defMessage & P.files .~ diff
where
go :: DiffEffects sig m => BlobPair -> m TOCSummaryFile
go blobPair = decoratingDiffWith summarizeDiffParsers decorateTerm (pure . summarizeDiff blobPair) blobPair
`catchError` \(SomeException e) ->
pure $ TOCSummaryFile path lang mempty (V.fromList [TOCSummaryError (T.pack (show e)) Nothing])
pure $ defMessage
& P.path .~ path
& P.language .~ lang
& P.changes .~ mempty
& P.errors .~ [defMessage & P.error .~ T.pack (show e) & P.maybe'span .~ Nothing]
where path = T.pack $ pathKeyForBlobPair blobPair
lang = bridging # languageForBlobPair blobPair

33
src/Semantic/Api/Terms.hs
View File

@ -18,18 +18,20 @@ import Data.Either
import Data.Graph
import Data.JSON.Fields
import Data.Language
import Data.ProtoLens (defMessage)
import Data.Quieterm
import Data.Term
import qualified Data.Text as T
import qualified Data.Vector as V
import Parsing.Parser
import Prologue
import Proto.Semantic as P hiding (Blob)
import Proto.Semantic_Fields as P
import Proto.Semantic_JSON()
import Rendering.Graph
import Rendering.JSON hiding (JSON)
import qualified Rendering.JSON
import Semantic.Api.Bridge
import Semantic.Config
import Semantic.Proto.SemanticPB hiding (Blob)
import Semantic.Task
import Serializing.Format hiding (JSON)
import qualified Serializing.Format as Format
@ -37,18 +39,26 @@ import Source.Loc
import qualified Language.Python as Py
termGraph :: (Traversable t, Member Distribute sig, ParseEffects sig m) => t Blob -> m ParseTreeGraphResponse
termGraph blobs = ParseTreeGraphResponse . V.fromList . toList <$> distributeFor blobs go
termGraph blobs = do
terms <- distributeFor blobs go
pure $ defMessage
& P.files .~ toList terms
where
go :: ParseEffects sig m => Blob -> m ParseTreeFileGraph
go blob = parseWith jsonGraphTermParsers (pure . jsonGraphTerm blob) blob
`catchError` \(SomeException e) ->
pure (ParseTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))]))
pure $ defMessage
& P.path .~ path
& P.language .~ lang
& P.vertices .~ mempty
& P.edges .~ mempty
& P.errors .~ [defMessage & P.error .~ T.pack (show e)]
where
path = T.pack $ blobPath blob
lang = bridging # blobLanguage blob
data TermOutputFormat
= TermJSONTree
| TermJSONGraph
@ -137,7 +147,12 @@ class JSONGraphTerm term where
instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphTerm (Term syntax) where
jsonGraphTerm blob t
= let graph = renderTreeGraph t
toEdge (Edge (a, b)) = TermEdge (vertexId a) (vertexId b)
in ParseTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty where
path = T.pack $ blobPath blob
lang = bridging # blobLanguage blob
toEdge (Edge (a, b)) = defMessage & P.source .~ a^.vertexId & P.target .~ b^.vertexId
path = T.pack $ blobPath blob
lang = bridging # blobLanguage blob
in defMessage
& P.path .~ path
& P.language .~ lang
& P.vertices .~ vertexList graph
& P.edges .~ fmap toEdge (edgeList graph)
& P.errors .~ mempty

1
src/Semantic/CLI.hs
View File

@ -33,6 +33,7 @@ import Control.Exception (Exception(..), throwTo)
import Data.Typeable (Typeable)
import System.Posix.Signals
import System.Mem.Weak (deRefWeak)
import Proto.Semantic_JSON()
newtype SignalException = SignalException Signal
deriving (Show, Typeable)

1368
src/Semantic/Proto/SemanticPB.hs
View File

File diff suppressed because it is too large Load Diff

5
src/Serializing/Format.hs
View File

@ -14,7 +14,8 @@ import Data.ByteString.Builder
import Language.Haskell.HsColour
import Language.Haskell.HsColour.Colourise
import Prologue
import Proto3.Suite as Proto3
import Data.ProtoLens.Encoding as Proto
import Data.ProtoLens.Message (Message)
import Serializing.SExpression
import Text.Show.Pretty
@ -33,4 +34,4 @@ runSerialize _ JSON = (<> "\n") . fromEncoding . toEncodin
runSerialize _ (SExpression opts) = serializeSExpression opts
runSerialize Colourful Show = (<> "\n") . stringUtf8 . hscolour TTY defaultColourPrefs False False "" False . ppShow
runSerialize Plain Show = (<> "\n") . stringUtf8 . show
runSerialize _ Proto = lazyByteString . Proto3.toLazyByteString
runSerialize _ Proto = Proto.buildMessage

2
test/Graphing/Calls/Spec.hs
View File

@ -3,7 +3,7 @@
module Graphing.Calls.Spec ( spec ) where
import Prelude hiding (readFile)
import SpecHelpers hiding (readFile)
import SpecHelpers
import Algebra.Graph

2
test/Semantic/IO/Spec.hs
View File

@ -15,7 +15,7 @@ import Data.Blob
import Data.Handle
import qualified Semantic.Git as Git
import Shelly (cd, run_, shelly, silently, touchfile, writefile)
import SpecHelpers hiding (readFile)
import SpecHelpers
import System.Path ((</>))
import qualified System.Path as Path