Merge pull request #1903 from github/protobuf-instances

Protobuf instances

.gitmodules

@@ -16,3 +16,9 @@
 [submodule "vendor/fastsum"]
 	path = vendor/fastsum
 	url = git@github.com:patrickt/fastsum.git
+[submodule "vendor/proto3-wire"]
+	path = vendor/proto3-wire
+	url = https://github.com/joshvera/proto3-wire
+[submodule "vendor/proto3-suite"]
+	path = vendor/proto3-suite
+	url = https://github.com/joshvera/proto3-suite

semantic.cabal

@@ -208,6 +208,8 @@ library
                      , text >= 1.2.1.3
                      , these
                      , time
+                     , proto3-suite
+                     , proto3-wire
                      , unix
                      , unordered-containers
                      , haskell-tree-sitter

semantic.proto

@@ -1,4 +1,5 @@
 syntax = "proto3";
+import "types.proto";
 package semantic;
 
 message HealthCheckRequest {
@@ -33,12 +34,6 @@ message BlobPair {
   Blob after = 2;
 }
 
-message Blob {
-  string source = 1;
-  string path = 2;
-  string language = 3;
-}
-
 message SummariesResponse {
   repeated Summary changes = 1;
   repeated Error errors = 2;
@@ -61,13 +56,3 @@ message Error {
   Span span = 2;
   string language = 3;
 }
-
-message Span {
-  Pos start = 1;
-  Pos end = 2;
-}
-
-message Pos {
-  int32 line = 1;
-  int32 column = 2;
-}

src/Data/Blob.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
 module Data.Blob
 ( Blob(..)
 , nullBlob
@@ -14,6 +15,7 @@ module Data.Blob
 ) where
 
 import Prologue
+import Proto3.Suite
 import Data.Aeson
 import Data.JSON.Fields
 import Data.Language
@@ -26,7 +28,7 @@ data Blob = Blob
   , blobPath :: FilePath -- ^ The file path to the blob.
   , blobLanguage :: Maybe Language -- ^ The language of this blob. Nothing denotes a langauge we don't support yet.
   }
-  deriving (Show, Eq)
+  deriving (Show, Eq, Generic, Message, Named)
 
 nullBlob :: Blob -> Bool
 nullBlob Blob{..} = nullSource blobSource

src/Data/Language.hs

@@ -3,6 +3,7 @@ module Data.Language where
 
 import Prologue
 import Data.Aeson
+import Proto3.Suite
 
 -- | A programming language.
 data Language
@@ -16,7 +17,7 @@ data Language
     | Ruby
     | TypeScript
     | PHP
-    deriving (Eq, Generic, Ord, Read, Show, ToJSON)
+    deriving (Eq, Generic, Ord, Read, Show, ToJSON, Named, Enum, Finite, Message)
 
 -- | Returns a Language based on the file extension (including the ".").
 languageForType :: String -> Maybe Language

src/Data/Source.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Data.Source
 ( Source
 , sourceBytes
@@ -36,10 +36,11 @@ import Data.Span
 import Data.String (IsString(..))
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
+import Proto3.Suite
 
 -- | The contents of a source file, represented as a 'ByteString'.
 newtype Source = Source { sourceBytes :: B.ByteString }
-  deriving (Eq, IsString, Show)
+  deriving (Eq, IsString, Show, Generic, MessageField)
 
 fromBytes :: B.ByteString -> Source
 fromBytes = Source

src/Data/Span.hs

@@ -11,6 +11,9 @@ module Data.Span
 ) where
 
 import Data.Aeson ((.=), (.:))
+import Proto3.Suite
+import Proto3.Wire.Decode as Decode
+import Proto3.Wire.Encode as Encode
 import qualified Data.Aeson as A
 import Data.JSON.Fields
 import Data.Semilattice.Lower
@@ -22,7 +25,15 @@ data Pos = Pos
   { posLine   :: !Int
   , posColumn :: !Int
   }
-  deriving (Show, Read, Eq, Ord, Generic, Hashable)
+  deriving (Show, Read, Eq, Ord, Generic, Hashable, Named, Message)
+
+instance MessageField Pos where
+  encodeMessageField num = Encode.embedded num . encodeMessage (fieldNumber 1)
+  decodeMessageField = fromMaybe def <$> Decode.embedded (decodeMessage (fieldNumber 1))
+  protoType pr = messageField (Prim $ Named (Single (nameOf pr))) Nothing
+
+instance HasDefault Pos where
+  def = Pos 1 1
 
 instance A.ToJSON Pos where
   toJSON Pos{..} =
@@ -37,7 +48,7 @@ data Span = Span
   { spanStart :: Pos
   , spanEnd   :: Pos
   }
-  deriving (Show, Read, Eq, Ord, Generic, Hashable)
+  deriving (Show, Read, Eq, Ord, Generic, Hashable, Named, Message)
 
 spanFromSrcLoc :: SrcLoc -> Span
 spanFromSrcLoc = Span . (Pos . srcLocStartLine <*> srcLocStartCol) <*> (Pos . srcLocEndLine <*> srcLocEndCol)

src/Data/Syntax.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables #-}
-{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack
+{-# LANGUAGE AllowAmbiguousTypes, DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, KindSignatures, RankNTypes, ConstraintKinds #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints -fno-warn-orphans #-} -- For HasCallStack
 module Data.Syntax where
 
 import Data.Abstract.Evaluatable
@@ -16,7 +16,13 @@ import Prelude
 import Prologue
 import qualified Assigning.Assignment as Assignment
 import qualified Data.Error as Error
-
+import Proto3.Suite.Class
+import Proto3.Wire.Decode
+import Proto3.Wire.Types
+import GHC.Types (Constraint)
+import GHC.TypeLits
+import qualified Proto3.Suite.DotProto as Proto
+import Data.Char (toLower)
 -- Combinators
 
 -- | Lift syntax and an annotation into a term, injecting the syntax into a union & ensuring the annotation encompasses all children.
@@ -97,12 +103,37 @@ infixContext :: (Context :< fs, Assignment.Parsing m, Semigroup a, HasCallStack,
              -> m (Sum fs (Term (Sum fs) a))
 infixContext context left right operators = uncurry (&) <$> postContextualizeThrough context left (asum operators) <*> postContextualize context right
 
+instance (Apply Message1 fs, Generate Message1 fs fs, Generate Named1 fs fs) => Message1 (Sum fs) where
+  liftEncodeMessage encodeMessage num = apply @Message1 (liftEncodeMessage encodeMessage num)
+  liftDecodeMessage decodeMessage _ = oneof undefined listOfParsers
+    where
+      listOfParsers =
+        generate @Message1 @fs @fs (\ (_ :: proxy f) i -> let num = FieldNumber (fromInteger (succ i)) in [(num, fromJust <$> embedded (inject @f @fs <$> liftDecodeMessage decodeMessage num))])
+  liftDotProto _ =
+    [Proto.DotProtoMessageOneOf (Proto.Single "syntax") (generate @Named1 @fs @fs (\ (_ :: proxy f) i ->
+      let
+        num = FieldNumber (fromInteger (succ i))
+        fieldType = Proto.Prim (Proto.Named . Proto.Single $ nameOf1 (Proxy @f))
+        fieldName = Proto.Single (camelCase $ nameOf1 (Proxy @f))
+        camelCase (x : xs) = toLower x : xs
+        camelCase [] = []
+      in
+        [ Proto.DotProtoField num fieldType fieldName [] Nothing ]))]
+
+class Generate (c :: (* -> *) -> Constraint) (all :: [* -> *]) (fs :: [* -> *]) where
+  generate :: Monoid b => (forall f proxy. (Element f all, c f) => proxy f -> Integer -> b) -> b
+
+instance Generate c all '[] where
+  generate _ = mempty
+
+instance (Element f all, c f, Generate c all fs) => Generate c all (f ': fs) where
+  generate each = each (Proxy @f) (natVal (Proxy @(ElemIndex f all))) `mappend` generate @c @all @fs each
 
 -- Common
 
 -- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable).
 newtype Identifier a = Identifier { name :: Name }
-  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, ToJSONFields1)
+  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, Named1, ToJSONFields1)
 
 instance Eq1 Identifier where liftEq = genericLiftEq
 instance Ord1 Identifier where liftCompare = genericLiftCompare
@@ -144,7 +175,7 @@ instance Evaluatable AccessibilityModifier
 --
 --   This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'.
 data Empty a = Empty
-  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
+  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
 
 instance ToJSONFields1 Empty
 
@@ -155,7 +186,6 @@ instance Show1 Empty where liftShowsPrec _ _ _ _ = showString "Empty"
 instance Evaluatable Empty where
   eval _ = pure (Rval unit)
 
-
 -- | Syntax representing a parsing or assignment error.
 data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }
   deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)

src/Data/Syntax/Literal.hs

@@ -1,20 +1,21 @@
-{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, ViewPatterns #-}
+{-# LANGUAGE DataKinds, DeriveAnyClass, DeriveGeneric, MultiParamTypeClasses, ViewPatterns, ScopedTypeVariables #-}
 module Data.Syntax.Literal where
 
-import Data.JSON.Fields
-import Data.Abstract.Evaluatable
-import Data.ByteString.Char8 (readInteger, unpack)
+import           Data.Abstract.Evaluatable
+import           Data.ByteString.Char8 (readInteger, unpack)
 import qualified Data.ByteString.Char8 as B
-import Data.Scientific.Exts
-import Diffing.Algorithm
-import Prelude hiding (Float, null)
-import Prologue hiding (Set, hash, null)
-import Text.Read (readMaybe)
+import           Data.JSON.Fields
+import           Data.Scientific.Exts
+import           Diffing.Algorithm
+import           Prelude hiding (Float, null)
+import           Prologue hiding (Set, hash, null)
+import           Proto3.Suite.Class
+import           Text.Read (readMaybe)
 
 -- Boolean
 
-newtype Boolean a = Boolean Bool
-  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
+newtype Boolean a = Boolean { booleanContent :: Bool }
+  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
 
 true :: Boolean a
 true = Boolean True
@@ -57,7 +58,7 @@ instance ToJSONFields1 Data.Syntax.Literal.Integer where
 
 -- | A literal float of unspecified width.
 newtype Float a = Float { floatContent  :: ByteString }
-  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
+  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
 
 instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq
 instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare
@@ -144,7 +145,7 @@ instance ToJSONFields1 InterpolationElement
 
 -- | A sequence of textual contents within a string literal.
 newtype TextElement a = TextElement { textElementContent :: ByteString }
-  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
+  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
 
 instance Eq1 TextElement where liftEq = genericLiftEq
 instance Ord1 TextElement where liftCompare = genericLiftCompare
@@ -157,7 +158,7 @@ instance Evaluatable TextElement where
   eval (TextElement x) = pure (Rval (string x))
 
 data Null a = Null
-  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
+  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
 
 instance Eq1 Null where liftEq = genericLiftEq
 instance Ord1 Null where liftCompare = genericLiftCompare
@@ -199,7 +200,7 @@ instance Evaluatable Regex
 -- Collections
 
 newtype Array a = Array { arrayElements :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
+  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
 
 instance Eq1 Array where liftEq = genericLiftEq
 instance Ord1 Array where liftCompare = genericLiftCompare
@@ -211,7 +212,7 @@ instance Evaluatable Array where
   eval (Array a) = Rval <$> (array =<< traverse subtermValue a)
 
 newtype Hash a = Hash { hashElements :: [a] }
-  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
+  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
 
 instance Eq1 Hash where liftEq = genericLiftEq
 instance Ord1 Hash where liftCompare = genericLiftCompare
@@ -223,7 +224,7 @@ instance Evaluatable Hash where
   eval t = Rval . hash <$> traverse (subtermValue >=> asPair) (hashElements t)
 
 data KeyValue a = KeyValue { key :: !a, value :: !a }
-  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1)
+  deriving (Diffable, Eq, Foldable, Functor, Generic1, Hashable1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1, Named1, Message1)
 
 instance Eq1 KeyValue where liftEq = genericLiftEq
 instance Ord1 KeyValue where liftCompare = genericLiftCompare

src/Data/Term.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators #-}
+{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators, ScopedTypeVariables #-}
 module Data.Term
 ( Term(..)
 , termIn
@@ -16,6 +16,7 @@ import Data.Aeson
 import Data.JSON.Fields
 import Data.Record
 import Text.Show
+import Proto3.Suite.Class
 
 -- | A Term with an abstract syntax tree and an annotation.
 newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) }
@@ -78,6 +79,14 @@ instance Show1 f => Show1 (Term f) where
 instance (Show1 f, Show a) => Show (Term f a) where
   showsPrec = showsPrec1
 
+instance Message1 f => Message (Term f ()) where
+  encodeMessage num (Term (In _ f)) = liftEncodeMessage encodeMessage num f
+  decodeMessage num = termIn () <$> liftDecodeMessage decodeMessage num
+  dotProto _ = liftDotProto (Proxy @(f (Term f ())))
+
+instance Named (Term f a) where
+  nameOf _ = "Term"
+
 instance Ord1 f => Ord1 (Term f) where
   liftCompare comp = go where go t1 t2 = liftCompare2 comp go (unTerm t1) (unTerm t2)
 

types.proto

@@ -0,0 +1,45 @@
+syntax = "proto3";
+package semantic;
+enum Language {Go = 0;
+               Haskell = 1;
+               JavaScript = 2;
+               JSON = 3;
+               JSX = 4;
+               Markdown = 5;
+               Python = 6;
+               Ruby = 7;
+               TypeScript = 8;
+               PHP = 9;}
+message Blob { bytes blobSource = 1;
+               string blobPath = 2;
+               Language blobLanguage = 3;
+             }
+message Pos { int64 posLine = 1;
+              int64 posColumn = 2;
+            }
+message Span { Pos spanStart = 1;
+               Pos spanEnd = 2;
+             }
+message Array { repeated Term arrayElements = 1;
+              }
+message Boolean { bool booleanContent = 1;
+                }
+message Hash { repeated Term hashElements = 1;
+             }
+message Float { bytes floatContent = 1;
+              }
+message KeyValue { Term key = 1;
+                   Term value = 2;
+                 }
+message Null {
+             }
+message TextElement { bytes textElementContent = 1;
+                    }
+message Term { oneof syntax {Array array = 1;
+                             Boolean boolean = 2;
+                             Hash hash = 3;
+                             Float float = 4;
+                             KeyValue keyValue = 5;
+                             Null null = 6;
+                             TextElement textElement = 7;}
+             }

vendor/fastsum

@@ -1 +1 @@
-Subproject commit 2310af6de3d3c337d671cdf9fe3e007990fdb1e4
+Subproject commit dbeff0af57fcea85bca07ff5a8149301dd3b084c

vendor/proto3-suite

@@ -0,0 +1 @@
+Subproject commit c75b250e82481e23d2ff586b3e841834b5d93ff9

vendor/proto3-wire

@@ -0,0 +1 @@
+Subproject commit c8792bc33154e849239b1c91ffe06af2e765d734