Support for empty statement (#260)

Fixes issue #257

proto3-suite.cabal

@@ -49,7 +49,7 @@ source-repository head
 
 common common
   default-extensions:
-    DeriveDataTypeable DeriveGeneric
+    BlockArguments DeriveDataTypeable DeriveGeneric ImportQualifiedPost
 
 library
   import: common
@@ -186,6 +186,8 @@ test-suite tests
     --TestProtoProtocPlugin
     Test.Proto.Generate.Name
     Test.Proto.Generate.Name.Gen
+    Test.Proto.Parse
+    Test.Proto.Parse.Core
     Test.Proto.Parse.Gen
     Test.Proto.Parse.Option
 

shell.nix

@@ -28,6 +28,7 @@ let
 in proto3-suite.env.overrideAttrs (old: {
   buildInputs = (old.buildInputs or []) ++ [
     pkgs.cabal-install
+    pkgs.protobuf
     pkgs.python3Packages.virtualenv
   ];
 })

src/Proto3/Suite/DotProto/AST.hs

@@ -286,7 +286,6 @@ type DotProtoEnumValue = Int32
 data DotProtoEnumPart
   = DotProtoEnumField DotProtoIdentifier DotProtoEnumValue [DotProtoOption]
   | DotProtoEnumOption DotProtoOption
-  | DotProtoEnumEmpty
   deriving (Data, Eq, Generic, Ord, Show)
 
 instance Arbitrary DotProtoEnumPart where
@@ -313,7 +312,6 @@ instance Arbitrary Streaming where
 data DotProtoServicePart
   = DotProtoServiceRPCMethod RPCMethod
   | DotProtoServiceOption DotProtoOption
-  | DotProtoServiceEmpty
   deriving (Data, Eq, Generic, Ord, Show)
 
 instance Arbitrary DotProtoServicePart where

src/Proto3/Suite/DotProto/Parsing.hs

@@ -1,6 +1,7 @@
 -- | This module contains a near-direct translation of the proto3 grammar
 --   It uses String for easier compatibility with DotProto.Generator, which needs it for not very good reasons
 
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
@@ -26,6 +27,9 @@ module Proto3.Suite.DotProto.Parsing
     -- * Extension Parsers
   , pExtendStmt
   , pExtendKw
+
+    -- * Empty Statement
+  , pEmptyStmt
   ) where
 
 import Prelude hiding (fail)
@@ -38,6 +42,7 @@ import Control.Monad (fail)
 import Control.Monad.Fail
 #endif
 import qualified Data.Char as Char
+import Data.Maybe (catMaybes)
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import qualified Data.List.NonEmpty as NE
 import Data.Functor
@@ -302,7 +307,7 @@ definition :: ProtoParser DotProtoDefinition
 definition =
   choice
     [ try message
-    , try enum
+    , try pEnumDefn
     , service
     ]
 
@@ -378,10 +383,11 @@ pOptionKw = do
 --------------------------------------------------------------------------------
 -- service statements
 
-servicePart :: ProtoParser DotProtoServicePart
-servicePart = DotProtoServiceRPCMethod <$> rpc
-          <|> DotProtoServiceOption <$> pOptionStmt
-          <|> DotProtoServiceEmpty <$ empty
+servicePart :: ProtoParser (Maybe DotProtoServicePart)
+servicePart =
+  try (fmap (Just . DotProtoServiceRPCMethod) rpc)
+    <|> try (fmap (Just . DotProtoServiceOption) pOptionStmt)
+    <|> Nothing <$ pEmptyStmt
 
 rpcOptions :: ProtoParser [DotProtoOption]
 rpcOptions = braces $ many pOptionStmt
@@ -402,33 +408,41 @@ rpc = do symbol "rpc"
          return RPCMethod{..}
 
 service :: ProtoParser DotProtoDefinition
-service = do symbol "service"
-             name <- singleIdentifier
-             statements <- braces (many servicePart)
-             return $ DotProtoService mempty name statements
+service = do
+  symbol "service"
+  name <- singleIdentifier
+  statements <- braces do
+    results <- many servicePart
+    pure (catMaybes results)
+  return $ DotProtoService mempty name statements
 
 --------------------------------------------------------------------------------
 -- message definitions
 
 message :: ProtoParser DotProtoDefinition
-message = do symbol "message"
-             name <- singleIdentifier
-             body <- braces (many messagePart)
-             return $ DotProtoMessage mempty name body
+message = do
+  symbol "message"
+  name <- singleIdentifier
+  body <- braces do
+    results <- many messagePart
+    pure (catMaybes results)
+  pure (DotProtoMessage mempty name body)
 
 messageOneOf :: ProtoParser DotProtoMessagePart
 messageOneOf = do symbol "oneof"
                   name <- singleIdentifier
                   body <- braces (many messageField)
                   return $ DotProtoMessageOneOf name body
 
-messagePart :: ProtoParser DotProtoMessagePart
-messagePart = try (DotProtoMessageDefinition <$> enum)
-          <|> try (DotProtoMessageReserved   <$> reservedField)
-          <|> try (DotProtoMessageDefinition <$> message)
-          <|> try messageOneOf
-          <|> try (DotProtoMessageField      <$> messageField)
-          <|> try (DotProtoMessageOption     <$> pOptionStmt)
+messagePart :: ProtoParser (Maybe DotProtoMessagePart)
+messagePart =
+  try (Just . DotProtoMessageDefinition <$> pEnumDefn)
+    <|> try (Just . DotProtoMessageReserved   <$> reservedField)
+    <|> try (Just . DotProtoMessageDefinition <$> message)
+    <|> try (fmap Just messageOneOf)
+    <|> try (Just . DotProtoMessageField      <$> messageField)
+    <|> try (Just . DotProtoMessageOption     <$> pOptionStmt)
+    <|> (Nothing <$ pEmptyStmt)
 
 messageType :: ProtoParser DotProtoType
 messageType = try mapType <|> try repType <|> (Prim <$> primType)
@@ -461,16 +475,20 @@ enumField = do fname <- identifier
                return $ DotProtoEnumField fname fpos opts
 
 
-enumStatement :: ProtoParser DotProtoEnumPart
-enumStatement = try (DotProtoEnumOption <$> pOptionStmt)
-            <|> enumField
-            <|> empty $> DotProtoEnumEmpty
+enumStatement :: ProtoParser (Maybe DotProtoEnumPart)
+enumStatement =
+  try (fmap (Just . DotProtoEnumOption) pOptionStmt)
+    <|> try (fmap Just enumField)
+    <|> (Nothing <$ pEmptyStmt)
 
-enum :: ProtoParser DotProtoDefinition
-enum = do symbol "enum"
-          ename <- singleIdentifier
-          ebody <- braces (many enumStatement)
-          return $ DotProtoEnum mempty ename ebody
+pEnumDefn :: ProtoParser DotProtoDefinition
+pEnumDefn = do
+  symbol "enum"
+  ename <- singleIdentifier
+  ebody <- braces do
+    results <- many enumStatement
+    pure (catMaybes results)
+  pure (DotProtoEnum mempty ename ebody)
 
 --------------------------------------------------------------------------------
 -- field reservations
@@ -502,7 +520,9 @@ pExtendStmt :: ProtoParser (DotProtoIdentifier, [DotProtoMessagePart])
 pExtendStmt = do
   pExtendKw
   idt <- identifier
-  fxs <- braces (many messagePart)
+  fxs <- braces do
+    results <- many messagePart
+    pure (catMaybes results)
   pure (idt, fxs)
 
 -- | Parses a single keyword token "extend".
@@ -513,3 +533,11 @@ pExtendKw = do
   spaces
   token (string "extend" >> notFollowedBy alphaNum)
     <?> "keyword 'extend'"
+
+-- Parse - Empty Statements ----------------------------------------------------
+
+-- | Parses a single empty statement (i.e. a semicolon).
+--
+-- See: https://protobuf.dev/reference/protobuf/proto3-spec/#emptystatement
+pEmptyStmt :: ProtoParser ()
+pEmptyStmt = token (() <$ char ';') <?> "empty statement"

src/Proto3/Suite/DotProto/Rendering.hs

@@ -157,8 +157,6 @@ prettyPrintProtoDefinition opts = defn where
     <> PP.text ";"
   enumPart _       (DotProtoEnumOption opt)
     = PP.text "option" <+> pPrint opt <> PP.text ";"
-  enumPart _       DotProtoEnumEmpty
-    = PP.empty
 
 instance Pretty DotProtoServicePart where
   pPrint (DotProtoServiceRPCMethod RPCMethod{..})
@@ -171,7 +169,6 @@ instance Pretty DotProtoServicePart where
           [] -> PP.text ";"
           _  -> PP.braces . PP.vcat $ topOption <$> rpcMethodOptions
   pPrint (DotProtoServiceOption option) = topOption option
-  pPrint DotProtoServiceEmpty           = PP.empty
 
 instance Pretty Streaming where
   pPrint Streaming    = PP.text "stream"

test-files/test_proto_empty_field.proto

@@ -0,0 +1,15 @@
+
+syntax = "proto3";
+package TestProtoEmptyField;
+
+enum EnumWithEmptyField {
+  enum_foo = 0;
+  ;
+  enum_bar = 1;
+}
+
+message MessageWithEmptyField {
+  uint32 foo = 1;
+  ;
+  uint32 bar = 2;
+}

tests/Main.hs

@@ -54,8 +54,8 @@ tests logger = testGroup "Tests"
   , parserUnitTests
   , dotProtoUnitTests
   , codeGenTests logger
-  , Test.Proto.Generate.Name.tests
-  , Test.Proto.Parse.Option.tests
+  , Test.Proto.Generate.Name.testTree
+  , Test.Proto.Parse.Option.testTree
 
 #ifdef DHALL
   , dhallTests
@@ -269,6 +269,7 @@ dotProtoUnitTests :: TestTree
 dotProtoUnitTests = testGroup ".proto parsing tests"
   [ dotProtoParseTrivial
   , dotProtoPrintTrivial
+  , dotProtoParseEmptyStatement
   , dotProtoRoundtripTrivial
   , dotProtoRoundtripSimpleMessage
   , dotProtoRoundtripExtend
@@ -288,6 +289,44 @@ dotProtoPrintTrivial = testCase
   "Print a content-less DotProto" $
   testDotProtoPrint trivialDotProto "syntax = \"proto3\";"
 
+dotProtoParseEmptyStatement :: TestTree
+dotProtoParseEmptyStatement =
+  testCase "Parse empty statements" (testDotProtoParse filePath dotProtoAST)
+  where
+    filePath :: FilePath
+    filePath = testFilesPfx <> "test_proto_empty_field.proto"
+
+    dotProtoAST :: DotProto
+    dotProtoAST =
+      DotProto [] []
+        (DotProtoPackageSpec (Single "TestProtoEmptyField"))
+        [ DotProtoEnum
+            ""
+            (Single "EnumWithEmptyField")
+            [ DotProtoEnumField (Single "enum_foo") 0 []
+            , DotProtoEnumField (Single "enum_bar") 1 []
+            ]
+        , DotProtoMessage
+            ""
+            (Single "MessageWithEmptyField")
+            [ DotProtoMessageField (DotProtoField
+                { dotProtoFieldNumber = 1
+                , dotProtoFieldType = Prim UInt32
+                , dotProtoFieldName = Single "foo"
+                , dotProtoFieldOptions = []
+                , dotProtoFieldComment = ""
+                })
+            , DotProtoMessageField (DotProtoField
+                { dotProtoFieldNumber = 2
+                , dotProtoFieldType = Prim UInt32
+                , dotProtoFieldName = Single "bar"
+                , dotProtoFieldOptions = []
+                , dotProtoFieldComment = ""
+                })
+            ]
+        ]
+        (DotProtoMeta (Path (testFilesPfx NE.:| ["test_proto_empty_field.proto"])))
+
 dotProtoRoundtripTrivial :: TestTree
 dotProtoRoundtripTrivial = testCase
   "Printing then parsing a content-less DotProto yields an empty DotProto" $

tests/Test/Proto/Generate/Name.hs

@@ -4,7 +4,7 @@
 
 -- |
 --
-module Test.Proto.Generate.Name (tests) where
+module Test.Proto.Generate.Name (testTree) where
 
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.Hedgehog (testProperty)
@@ -20,8 +20,8 @@ import Proto3.Suite.DotProto.Generate
 
 -- -----------------------------------------------------------------------------
 
-tests :: TestTree
-tests =
+testTree :: TestTree
+testTree =
   testGroup
     "Test.Proto.Generate.Name"
     [ testProperty "filenames" resolve'protofile

tests/Test/Proto/Parse.hs

@@ -0,0 +1,21 @@
+
+module Test.Proto.Parse (testTree) where
+
+import Hedgehog (property, (===))
+
+import Proto3.Suite.DotProto.Parsing qualified as Proto3
+import Proto3.Suite.DotProto.Rendering ()
+
+import Test.Proto.Parse.Core (runParseTest)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Hedgehog (testProperty)
+
+--------------------------------------------------------------------------------
+
+testTree :: TestTree
+testTree =
+  testGroup
+    "Test.Proto.Parse"
+    [ testProperty "empty" $ property do
+        runParseTest Proto3.pEmptyStmt ";" === Right ()
+    ]

tests/Test/Proto/Parse/Core.hs

@@ -0,0 +1,24 @@
+
+module Test.Proto.Parse.Core
+  ( runParseTest
+  , parseTrip
+  ) where
+
+import Hedgehog (PropertyT)
+import Hedgehog qualified as Hedgehog
+
+import Text.Parsec (ParseError)
+import Text.Parsec qualified as Parsec
+import Text.PrettyPrint (render)
+import Text.PrettyPrint.HughesPJClass (Pretty, pPrint)
+
+import Proto3.Suite.DotProto.Parsing (ProtoParser)
+import Proto3.Suite.DotProto.Parsing qualified as Proto3
+
+--------------------------------------------------------------------------------
+
+runParseTest :: ProtoParser a -> String -> Either ParseError a
+runParseTest p = Parsec.parse (Proto3.runProtoParser p) ""
+
+parseTrip :: (Eq a, Pretty a, Show a) => a -> ProtoParser a -> PropertyT IO ()
+parseTrip x p = Hedgehog.tripping x (render . pPrint) (runParseTest p)