diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,9 +1,10 @@ # avro-parser-haskell -[![Actions Status](https://github.com/kutyel/avro-parser-haskell/workflows/Haskell%20CI/badge.svg)](https://github.com/kutyel/avro-parser-haskell/actions) +[![Actions Status](https://github.com/higherkindness/avro-parser-haskell/workflows/Haskell%20CI/badge.svg)](https://github.com/higherkindness/avro-parser-haskell/actions) [![Hackage](https://img.shields.io/hackage/v/language-avro.svg?logo=haskell)](https://hackage.haskell.org/package/language-avro) [![Stackage Nightly](http://stackage.org/package/language-avro/badge/nightly)](http://stackage.org/nightly/package/language-avro) [![Stackage LTS](http://stackage.org/package/language-avro/badge/lts)](http://stackage.org/lts/package/language-avro) +![Hackage-Deps](https://img.shields.io/hackage-deps/v/language-avro?style=flat) [![ormolu](https://img.shields.io/badge/styled%20with-ormolu-blueviolet)](https://github.com/tweag/ormolu) Language definition and parser for AVRO (`.avdl`) files. @@ -12,21 +13,17 @@ ```haskell #!/usr/bin/env stack --- stack --resolver lts-15.0 script --package language-avro,megaparsec,pretty-simple +-- stack --resolver lts-18.19 script --package language-avro,pretty-simple module Main where import Language.Avro.Parser (readWithImports) -import Text.Megaparsec.Error (ShowErrorComponent (..), errorBundlePretty) import Text.Pretty.Simple (pPrint) -instance ShowErrorComponent Char where - showErrorComponent = show - main :: IO () main = readWithImports "test" "PeopleService.avdl" - >>= either (putStrLn . errorBundlePretty) pPrint + >>= either putStrLn pPrint -- λ> -- Protocol -- { ns = Just diff --git a/language-avro.cabal b/language-avro.cabal --- a/language-avro.cabal +++ b/language-avro.cabal @@ -1,5 +1,5 @@ name: language-avro -version: 0.1.3.1 +version: 0.1.4.0 synopsis: Language definition and parser for AVRO files. description: Parser for the AVRO language specification, see README.md for more details. @@ -8,8 +8,8 @@ license: Apache-2.0 license-file: LICENSE author: Flavio Corpa -maintainer: flavio.corpa@47deg.com -copyright: Copyright © 2019-2020 +maintainer: flaviocorpa@gmail.com +copyright: Copyright © 2019-2022 category: Network build-type: Simple cabal-version: >=1.10 diff --git a/src/Language/Avro/Parser.hs b/src/Language/Avro/Parser.hs --- a/src/Language/Avro/Parser.hs +++ b/src/Language/Avro/Parser.hs @@ -33,6 +33,7 @@ import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L +import Text.Megaparsec.Error (errorBundlePretty) spaces :: MonadParsec Char T.Text m => m () spaces = L.space space1 (L.skipLineComment "//") (L.skipBlockComment "/*" "*/") @@ -105,9 +106,9 @@ parseImport :: MonadParsec Char T.Text m => m ImportType parseImport = reserved "import" - *> ( impHelper IdlImport "idl" - <|> impHelper ProtocolImport "protocol" - <|> impHelper SchemaImport "schema" + *> ( (impHelper IdlImport "idl" "Import of type IDL") + <|> (impHelper ProtocolImport "protocol" "Import of type protocol") + <|> (impHelper SchemaImport "schema" "Import of type schema") ) where impHelper :: MonadParsec Char T.Text m => (T.Text -> a) -> T.Text -> m a @@ -149,7 +150,7 @@ -- | Parses order annotations into the 'Order' structure. parseOrder :: MonadParsec Char T.Text m => m Order parseOrder = - symbol "@" *> reserved "order" + symbol "@" *> (reserved "order" "Order can be ascending/descending/ignore") *> parens ( Ascending <$ string "\"ascending\"" <|> Descending <$ string "\"descending\"" @@ -164,11 +165,12 @@ parseField :: MonadParsec Char T.Text m => m Field parseField = (\o t a n -> Field n a Nothing o t Nothing) -- FIXME: docs are not supported yet. - <$> optional parseOrder - <*> parseSchema - <*> option [] parseFieldAlias - <*> identifier - <* (symbol ";" <|> symbol "=" <* manyTill anySingle (symbol ";")) -- FIXME: default values are not supported yet. + <$> optional (parseOrder "Order of the field in the schema") + <*> (parseSchema "Type of the field in the schema") + <*> (option [] parseFieldAlias "Aliases of the field in the schema") + <*> (identifier "Name of the field in the schema") + -- FIXME: default values are not supported yet. + <* ((symbol ";" <|> symbol "=" <* manyTill anySingle (symbol ";")) "Semicolon or equals sign") -- | Parses arguments of methods into the 'Argument' structure. parseArgument :: MonadParsec Char T.Text m => m Argument @@ -178,12 +180,12 @@ parseMethod :: MonadParsec Char T.Text m => m Method parseMethod = (\r n a t o -> Method n a r t o) - <$> parseSchema - <*> identifier - <*> parens (option [] (lexeme $ sepBy1 parseArgument $ symbol ",")) - <*> option Null (reserved "throws" *> parseSchema) - <*> option False (True <$ reserved "oneway") - <* symbol ";" + <$> (parseSchema "Result type of the method") + <*> (identifier "Name of the method") + <*> (parens (option [] (lexeme $ sepBy1 parseArgument $ symbol ",")) "Arguments of the method") + <*> (option Null (reserved "throws" *> parseSchema) "If the method throws an exception") + <*> (option False (True <$ reserved "oneway") "If the method is `oneway` or not") + <* (symbol ";" "Should end with a semicolon") -- | Parses the special type @decimal@ into it's corresponding 'Decimal' structure. parseDecimal :: MonadParsec Char T.Text m => m Decimal @@ -224,14 +226,14 @@ ( flip Enum <$> option [] parseAliases <* reserved "enum" <*> parseTypeName - <*> pure Nothing -- docs are ignored for now... + <*> pure Nothing -- FIXME: docs are ignored for now... <*> parseVector identifier ) <|> try ( flip Record <$> option [] parseAliases <* (reserved "record" <|> reserved "error") <*> parseTypeName - <*> pure Nothing -- docs are ignored for now... + <*> pure Nothing -- FIXME: docs are ignored for now... <*> option [] (braces . many $ parseField) ) <|> NamedType . toNamedType <$> lexeme (sepBy1 identifier $ char '.') @@ -249,11 +251,11 @@ FilePath -> -- | initial file FilePath -> - IO (Either (ParseErrorBundle T.Text Char) Protocol) + IO (Either T.Text Protocol) readWithImports baseDir initialFile = do initial <- parseFile parseProtocol (baseDir initialFile) case initial of - Left e -> pure $ Left e + Left err -> pure $ Left $ T.pack (errorBundlePretty err) Right p -> do possibleImps <- traverse (oneOfTwo . T.unpack) [i | IdlImport i <- S.toList $ imports p] (lefts, rights) <- partitionEithers <$> traverse (>>>= readWithImports baseDir) possibleImps @@ -261,7 +263,7 @@ e : _ -> Left e _ -> Right $ S.foldl' (<>) p (S.fromList rights) where - oneOfTwo :: FilePath -> IO (Either (ParseErrorBundle T.Text Char) FilePath) + oneOfTwo :: FilePath -> IO (Either T.Text FilePath) oneOfTwo p = do let dir = takeDirectory initialFile path1 = baseDir p @@ -270,7 +272,7 @@ pure $ case options of (True, False) -> Right p (False, True) -> Right $ dir p - (False, False) -> runParser (fail $ "Import not found: " ++ p) initialFile "" + (False, False) -> Left $ T.pack ("Import not found: " ++ p) (True, True) | normalise dir == "." -> Right p - | otherwise -> runParser (fail $ "Duplicate files found: " ++ p) initialFile "" + | otherwise -> Left $ T.pack ("Duplicate files found: " ++ p) diff --git a/src/Language/Avro/Types.hs b/src/Language/Avro/Types.hs --- a/src/Language/Avro/Types.hs +++ b/src/Language/Avro/Types.hs @@ -7,20 +7,23 @@ where import Data.Avro -import Data.Set +import Data.Set (Set) import qualified Data.Text as T +import Text.Megaparsec.Error (ShowErrorComponent (..)) -- | Whole definition of protocol. -data Protocol - = Protocol - { ns :: Maybe Namespace, - pname :: T.Text, - imports :: Set ImportType, - types :: Set Schema, - messages :: Set Method - } +data Protocol = Protocol + { ns :: Maybe Namespace, + pname :: T.Text, + imports :: Set ImportType, + types :: Set Schema, + messages :: Set Method + } deriving (Eq, Show, Ord) +instance ShowErrorComponent Char where + showErrorComponent = show + instance Semigroup Protocol where p1 <> p2 = Protocol @@ -38,11 +41,10 @@ type Aliases = [TypeName] -- | Type for special annotations. -data Annotation - = Annotation - { ann :: T.Text, - abody :: T.Text - } +data Annotation = Annotation + { ann :: T.Text, + abody :: T.Text + } deriving (Eq, Show) -- | Type for the possible import types in 'Protocol'. @@ -53,20 +55,18 @@ deriving (Eq, Show, Ord) -- | Helper type for the arguments of 'Method'. -data Argument - = Argument - { atype :: Schema, - aname :: T.Text - } +data Argument = Argument + { atype :: Schema, + aname :: T.Text + } deriving (Eq, Show, Ord) -- | Type for methods/messages that belong to a protocol. -data Method - = Method - { mname :: T.Text, - args :: [Argument], - result :: Schema, - throws :: Schema, - oneway :: Bool - } +data Method = Method + { mname :: T.Text, + args :: [Argument], + result :: Schema, + throws :: Schema, + oneway :: Bool + } deriving (Eq, Show, Ord) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,10 +1,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -module Main - ( main, - ) -where +module Main (main) where import Data.Avro import qualified Data.Text as T @@ -16,54 +13,66 @@ import Text.Megaparsec (parse) import Text.Megaparsec.Error -instance ShowErrorComponent Char where - showErrorComponent = show - enumTest :: T.Text enumTest = - T.unlines - [ "@aliases([\"org.foo.KindOf\"])", - "enum Kind {", - "FOO,", - "BAR, // the bar enum value", - "BAZ", - "}" - ] + "@aliases([\"org.foo.KindOf\"])\n\ + \enum Kind {\n\ + \ FOO,\n\ + \ BAR, // the bar enum value\n\ + \ BAZ\n\ + \}" -simpleProtocol :: [T.Text] +simpleProtocol :: T.Text simpleProtocol = - [ "@namespace(\"example.seed.server.protocol.avro\")", - "protocol PeopleService {", - "import idl \"People.avdl\";", - "example.seed.server.protocol.avro.PeopleResponse getPerson(example.seed.server.protocol.avro.PeopleRequest request);", - "}" - ] + "@namespace(\"example.seed.server.protocol.avro\")\n\ + \protocol PeopleService {\n\ + \import idl \"People.avdl\";\n\ + \example.seed.server.protocol.avro.PeopleResponse getPerson(example.seed.server.protocol.avro.PeopleRequest request);\n\ + \}" simpleRecord :: T.Text simpleRecord = - T.unlines - [ "@aliases([\"org.foo.Person\"])", - "record Person {", - "string name;", - "int age;", - "date birthday;", - "}" - ] + "@aliases([\"org.foo.Person\"])\n\ + \record Person {\n\ + \ string name;\n\ + \ int age;\n\ + \ date birthday;\n\ + \}" complexRecord :: T.Text complexRecord = - T.unlines - [ "record TestRecord {", - "@order(\"ignore\")", - "string name;", - "@order(\"descending\")", - "Kind kind;", - "MD5 hash;", - "union { MD5, null} @aliases([\"hash\"]) nullableHash;", - "array arrayOfLongs;", - "}" - ] + "record TestRecord {\n\ + \ @order(\"ignore\")\n\ + \ string name;\n\ + \ @order(\"descending\")\n\ + \ Kind kind;\n\ + \ MD5 hash;\n\ + \ union { MD5, null} @aliases([\"hash\"]) nullableHash;\n\ + \ array arrayOfLongs;\n\ + \}" +avdlWithTypo :: T.Text +avdlWithTypo = + "@namespace(\"integrationtest\") \n\ + \protocol WeatherService { \n\ + \ record GetForecastRequest { \n\ + \ // NOTE: missing semicolon\n\ + \ string city\n\ + \ int days_required;\n\ + \ }\n\ + \ enum Weather {\n\ + \ SUNNY,\n\ + \ CLOUDY,\n\ + \ RAINY\n\ + \ }\n\ + \ record GetForecastResponse {\n\ + \ string last_updated;\n\ + \ array daily_forecasts;\n\ + \ }\n\ + \ void ping();\n\ + \ GetForecastResponse getForecast(GetForecastRequest req);\n\ + \}" + main :: IO () main = hspec $ do describe "Parse annotations" $ do @@ -183,17 +192,49 @@ (NamedType "example.seed.server.protocol.avro.PeopleResponse") Null False - it "should parse with imports" $ - parse parseProtocol "" (T.unlines . tail $ simpleProtocol) - `shouldParse` Protocol Nothing "PeopleService" [IdlImport "People.avdl"] [] [getPerson] it "should parse with namespace" $ - parse parseProtocol "" (T.unlines simpleProtocol) + parse parseProtocol "" simpleProtocol `shouldParse` Protocol (Just (Namespace ["example", "seed", "server", "protocol", "avro"])) "PeopleService" [IdlImport "People.avdl"] [] [getPerson] + it "should not parse protocols with typos" $ + parse parseProtocol "" avdlWithTypo + `shouldFailWith` err + 86 + ( utok '{' + <> etoks "array" + <> etoks "boolean" + <> etoks "bytes" + <> etoks "date" + <> etoks "decimal" + <> etoks "double" + <> etoks "enum" + <> etoks "error" + <> etoks "fixed" + <> etoks "float" + <> etoks "import" + <> etoks "int" + <> etoks "long" + <> etoks "map" + <> etoks "null" + <> etoks "record" + <> etoks "string" + <> etoks "time_ms" + <> etoks "timestamp_ms" + <> etoks "union" + <> etoks "uuid" + <> etoks "void" + <> etok '.' + <> etok ';' -- This is the actual one missing 🤔 + <> etok '@' + <> etok '`' + <> etok '}' + <> elabel "Result type of the method" + <> elabel "letter" + ) describe "Parse services" $ do it "should parse simple messages" $ parse parseMethod "" "string hello(string greeting);"