{-# LANGUAGE OverloadedLists, QuasiQuotes, TypeFamilies #-} module Nirum.ParserSpec where import Control.Monad (forM_) import Data.Either import Data.List (isSuffixOf) import Data.Maybe (fromJust) import System.Directory (getDirectoryContents) import qualified Data.ByteString as B import qualified Data.List.NonEmpty as NE import Data.String.QQ (s) import qualified Data.Text as T import qualified Data.Text.Encoding as E import Test.Hspec.Meta import Text.Megaparsec (eof, runParser) import Text.Megaparsec.Char (string) import Text.Megaparsec.Error (errorPos, parseErrorPretty) import Text.Megaparsec.Pos (Pos, SourcePos (sourceColumn, sourceLine), mkPos) import Text.Megaparsec.Text (Parser) import qualified Nirum.Parser as P import Nirum.Constructs (Construct (toCode)) import Nirum.Constructs.Annotation as A import Nirum.Constructs.Docs (Docs (Docs)) import Nirum.Constructs.DeclarationSet (DeclarationSet) import Nirum.Constructs.DeclarationSetSpec (SampleDecl (..)) import Nirum.Constructs.Identifier (fromText) import Nirum.Constructs.Module (Module (Module)) import Nirum.Constructs.Name (Name (..)) import Nirum.Constructs.Service ( Method (Method) , Parameter (Parameter) , Service (Service) ) import Nirum.Constructs.TypeDeclaration ( EnumMember (EnumMember) , Field (Field, fieldAnnotations) , Tag (Tag, tagAnnotations, tagFields) , Type (..) , TypeDeclaration (..) ) import Nirum.Constructs.TypeExpression ( TypeExpression ( ListModifier , MapModifier , OptionModifier , SetModifier , TypeIdentifier ) ) import Util (singleDocs) shouldBeRight :: (Eq l, Eq r, Show l, Show r) => Either l r -> r -> Expectation shouldBeRight actual expected = actual `shouldBe` Right expected erroredPos :: Either P.ParseError a -> (Pos, Pos) erroredPos left = (sourceLine pos, sourceColumn pos) where error' = head $ lefts [left] :: P.ParseError pos = NE.head (errorPos error') :: SourcePos helperFuncs :: (Show a) => Parser a -> ( T.Text -> Either P.ParseError a , T.Text -> Int -> Int -> Expectation ) helperFuncs parser = (parse', expectError) where parserAndEof = do r <- parser eof return r parse' = runParser parserAndEof "" expectError inputString line col = do line' <- mkPos line col' <- mkPos col let parseResult = parse' inputString parseResult `shouldSatisfy` isLeft let Left parseError = parseResult msg = parseErrorPretty parseError -- msg is just for debug print (erroredPos parseResult, msg) `shouldBe` ((line', col'), msg) fooAnnotationSet :: AnnotationSet fooAnnotationSet = A.singleton $ Annotation "foo" [("v", "bar")] bazAnnotationSet :: AnnotationSet bazAnnotationSet = A.singleton $ Annotation "baz" [] spec :: Spec spec = do describe "identifier" $ do let (parse', expectError) = helperFuncs P.identifier it "fails to parse an empty string" $ expectError "" 1 1 it "fails to parse an identifier starting with hyphen/underscore" $ do expectError "-ident" 1 1 expectError "-ident-ifier" 1 1 expectError "_ident" 1 1 expectError "_ident_ifier" 1 1 expectError "_ident-ifier" 1 1 expectError "-ident_ifier" 1 1 it "fails to parse an identifier ending with hyphen/underscore" $ do expectError "ident-" 1 7 expectError "ident-ifier-" 1 13 expectError "ident_" 1 7 expectError "ident_ifier_" 1 13 expectError "ident_ifier-" 1 13 expectError "ident-ifier_" 1 13 it "fails to parse an identifier with double hyphens/underscores" $ do expectError "ident--ifier" 1 7 expectError "ident__ifier" 1 7 expectError "ident-_ifier" 1 7 expectError "ident_-ifier" 1 7 it "fails to parse an identifier containing disallowed chars" $ do expectError "\xbb34\xd6a8\xd55c-\xc2dd\xbcc4\xc790" 1 1 expectError "invalid-\xc2dd\xbcc4\xc790" 1 9 let keywords = [ "enum", "record", "type", "unboxed", "union" , "Enum", "rEcord", "tyPE", "UNBOXED", "unioN" ] :: [T.Text] it "fails to parse bare identifier if it's a reserved keyword" $ forM_ keywords $ \ kwd -> expectError kwd 1 1 let identifier' = fromJust . fromText it "emits Identifier if succeeded to parse" $ do parse' "identifier" `shouldBeRight` identifier' "identifier" parse' "valid-identifier" `shouldBeRight` identifier' "valid-identifier" parse' "valid_identifier" `shouldBeRight` identifier' "valid_identifier" it "can parse even if a keyword is a prefix of identifier" $ do parse' "enumeration" `shouldBeRight` identifier' "enumeration" parse' "types" `shouldBeRight` identifier' "types" it "can parse reserved keywords iff they are quoted" $ forM_ keywords $ \ kwd -> parse' ('`' `T.cons` kwd `T.snoc` '`') `shouldBeRight` identifier' kwd describe "name" $ do let (parse', expectError) = helperFuncs P.name it "fails to parse an empty string" $ expectError "" 1 1 it "fails to parse if the name is not a valid identifier" $ do expectError "-ident" 1 1 expectError "-ident-ifier" 1 1 expectError "ident-" 1 7 expectError "ident-ifier-" 1 13 expectError "ident--ifier" 1 7 expectError "ident__ifier" 1 7 expectError "\xbb34\xd6a8\xd55c-\xc2dd\xbcc4\xc790" 1 1 expectError "invalid-\xc2dd\xbcc4\xc790" 1 9 it "fails to parse if the facial name is not a valid identifier" $ do expectError "-ident/valid" 1 1 expectError "-ident-ifier/valid" 1 1 expectError "ident-/valid" 1 7 expectError "ident-ifier-/valid" 1 13 expectError "ident--ifier/valid" 1 7 expectError "ident__ifier/valid" 1 7 expectError "\xbb34\xd6a8\xd55c-\xc2dd\xbcc4\xc790/valid" 1 1 expectError "invalid-\xc2dd\xbcc4\xc790/valid" 1 9 it "fails to parse if the behind name is not a valid identifier" $ do expectError "valid/-ident" 1 6 expectError "valid/-ident-ifier" 1 6 expectError "valid/ident-" 1 6 expectError "valid/ident-ifier-" 1 6 expectError "valid/ident--ifier" 1 6 expectError "valid/ident__ifier" 1 6 expectError "valid/\xbb34\xd6a8\xd55c-\xc2dd\xbcc4\xc790" 1 6 expectError "valid/invalid-\xc2dd\xbcc4\xc790" 1 6 it "emits Name if succeeded to parse" $ do parse' "name" `shouldBeRight` Name "name" "name" parse' "`enum`" `shouldBeRight` Name "enum" "enum" parse' "facial/behind" `shouldBeRight` Name "facial" "behind" parse' "facial / behind" `shouldBeRight` Name "facial" "behind" parse' "`enum`/`unboxed`" `shouldBeRight` Name "enum" "unboxed" parse' "`enum` / `unboxed`" `shouldBeRight` Name "enum" "unboxed" describe "annotation" $ do let (parse', expectError) = helperFuncs P.annotation context "with single argument" $ do let rightAnnotaiton = Annotation "name-abc" [("foo", "wo\"rld")] it "success" $ do parse' "@name-abc(foo=\"wo\\\"rld\")" `shouldBeRight` rightAnnotaiton parse' "@name-abc( foo=\"wo\\\"rld\")" `shouldBeRight` rightAnnotaiton parse' "@name-abc(foo=\"wo\\\"rld\" )" `shouldBeRight` rightAnnotaiton parse' "@name-abc( foo=\"wo\\\"rld\" )" `shouldBeRight` rightAnnotaiton parse' "@ name-abc ( foo=\"wo\\\"rld\")" `shouldBeRight` rightAnnotaiton parse' "@name-abc ( foo=\"wo\\\"rld\")" `shouldBeRight` rightAnnotaiton parse' "@name-abc(foo=\"wo\\\"rld\\n\")" `shouldBeRight` Annotation "name-abc" [("foo", "wo\"rld\n")] it "fails to parse if annotation name start with hyphen" $ do expectError "@-abc(v=\"helloworld\")" 1 2 expectError "@-abc-d(v = \"helloworld\")" 1 2 it "fails to parse without parentheses" $ expectError "@foobar \"helloworld\"" 1 9 it "fails to parse arguments without names" $ expectError "@foobar(\"helloworld\")" 1 9 it "fails to parse arguments without double quotes" $ expectError "@foobar(v=helloworld)" 1 11 context "without arguments" $ do let rightAnnotaiton = Annotation "name-abc" [] it "success" $ do parse' "@name-abc" `shouldBeRight` rightAnnotaiton parse' "@name-abc " `shouldBeRight` rightAnnotaiton parse' "@ name-abc" `shouldBeRight` rightAnnotaiton parse' "@name-abc()" `shouldBeRight` rightAnnotaiton parse' "@name-abc ( )" `shouldBeRight` rightAnnotaiton parse' "@ name-abc ( )" `shouldBeRight` rightAnnotaiton it "fails to parse if annotation name start with hyphen" $ do expectError "@-abc" 1 2 expectError "@-abc-d" 1 2 describe "annotationSet" $ do let (parse', expectError) = helperFuncs P.annotationSet Right annotationSet = fromList [ Annotation "a" [("arg", "b")] , Annotation "c" [] ] it "success" $ do parse' "@a(arg=\"b\")@c" `shouldBeRight` annotationSet parse' "@a(arg=\"b\") @c" `shouldBeRight` annotationSet parse' "@a(arg=\"b\") @c() " `shouldBeRight` annotationSet it "fails to parse if has duplicated name" $ expectError "@a(arg=\"b\")@a" 1 14 describe "typeIdentifier" $ do let (parse', expectError) = helperFuncs P.typeIdentifier it "fails to parse if the input is not a valid identifier" $ expectError "-invalid-type-identifier" 1 1 it "emits TypeIdentifier if succeeded to parse" $ do parse' "text" `shouldBeRight` TypeIdentifier "text" parse' "uuid" `shouldBeRight` TypeIdentifier "uuid" describe "optionModifier" $ do let (_, expectError') = helperFuncs P.optionModifier it "fails to parse if the input lacks a question mark" $ expectError' "lacks-qmark" 1 12 let parsers = [ P.optionModifier , P.typeExpression ] :: [Parser TypeExpression] forM_ parsers $ \ parser' -> do let (parse', expectError) = helperFuncs parser' it "cannot append two or more option modifiers" $ do expectError "text??" 1 6 expectError "text???" 1 6 expectError "text????" 1 6 it "emits OptionModifier if succeeded to parse" $ do parse' "text?" `shouldBeRight` OptionModifier (TypeIdentifier "text") parse' "uuid ?" `shouldBeRight` OptionModifier (TypeIdentifier "uuid") parse' "{text}?" `shouldBeRight` OptionModifier (SetModifier $ TypeIdentifier "text") it "can be appended to set modifier" $ parse' "{text}?" `shouldBeRight` OptionModifier (SetModifier $ TypeIdentifier "text") describe "setModifier" $ do let parsers = [ (1, P.setModifier) , (29, P.typeExpression) ] :: [(Int, Parser TypeExpression)] forM_ parsers $ \ (beginErrorPos, parser') -> do let (parse', expectError) = helperFuncs parser' it "fails to parse if input doesn't start with a curly bracket" $ expectError "not-start-with-curly-bracket}" 1 beginErrorPos it "fails to parse if input doesn't end with a curly bracket" $ expectError "{not-end-with-curly-bracket" 1 28 it "emits SetModifier if succeeded to parse" $ do parse' "{text}" `shouldBeRight` SetModifier (TypeIdentifier "text") parse' "{ uuid }" `shouldBeRight` SetModifier (TypeIdentifier "uuid") it "can be nested to represent 2d set" $ do parse' "{{text}}" `shouldBeRight` SetModifier (SetModifier $ TypeIdentifier "text") parse' "{[text]}" `shouldBeRight` SetModifier (ListModifier $ TypeIdentifier "text") it "can consist of optional elements" $ parse' "{uuid?}" `shouldBeRight` SetModifier (OptionModifier $ TypeIdentifier "uuid") describe "listModifier" $ do let parsers = [ (1, P.listModifier) , (30, P.typeExpression) ] :: [(Int, Parser TypeExpression)] forM_ parsers $ \ (beginErrorPos, parser') -> do let (parse', expectError) = helperFuncs parser' it "fails to parse if input doesn't start with a square bracket" $ expectError "not-start-with-square-bracket]" 1 beginErrorPos it "fails to parse if input doesn't end with a square bracket" $ expectError "[not-end-with-square-bracket" 1 29 it "emits ListModifier if succeeded to parse" $ do parse' "[text]" `shouldBeRight` ListModifier (TypeIdentifier "text") parse' "[ uuid ]" `shouldBeRight` ListModifier (TypeIdentifier "uuid") it "can be nested to represent 2d list" $ do parse' "[[text]]" `shouldBeRight` ListModifier (ListModifier $ TypeIdentifier "text") parse' "[{text}]" `shouldBeRight` ListModifier (SetModifier $ TypeIdentifier "text") it "can consist of optional elements" $ parse' "[uuid?]" `shouldBeRight` ListModifier (OptionModifier $ TypeIdentifier "uuid") describe "mapModifier" $ do let parsers = [ (1, P.mapModifier) , (15, P.typeExpression) ] :: [(Int, Parser TypeExpression)] forM_ parsers $ \ (beginErrorPos, parser') -> do let (parse', expectError) = helperFuncs parser' it "fails to parse if input doesn't start with a curly bracket" $ expectError "not-start-with: curly-bracket}" 1 beginErrorPos it "fails to parse if input doesn't end with a curly bracket" $ expectError "{not-end-with: curly-bracket" 1 29 it "emits MapModifier if succeeded to parse" $ do parse' "{uuid: text}" `shouldBeRight` MapModifier (TypeIdentifier "uuid") (TypeIdentifier "text") parse' "{ text : uuid }" `shouldBeRight` MapModifier (TypeIdentifier "text") (TypeIdentifier "uuid") it "can be nested to represent 2d map" $ do parse' "{uuid: {uuid: text}}" `shouldBeRight` MapModifier (TypeIdentifier "uuid") (MapModifier (TypeIdentifier "uuid") (TypeIdentifier "text")) parse' "{uuid: [text]}" `shouldBeRight` MapModifier (TypeIdentifier "uuid") (ListModifier $ TypeIdentifier "text") describe "typeExpression" $ do let (_, expectError) = helperFuncs P.typeExpression it "cannot append two or more option modifiers" $ do expectError "text??" 1 6 expectError "text???" 1 6 expectError "text????" 1 6 describe "docs" $ do let (parse', expectError) = helperFuncs P.docs it "emits Docs if succeeded to parse" $ do parse' "#docs" `shouldBeRight` Docs "docs\n" parse' "#docs\n#docs..." `shouldBeRight` Docs "docs\ndocs...\n" it "may ignore a leading space" $ do parse' "# docs" `shouldBeRight` Docs "docs\n" parse' "# docs\n# docs..." `shouldBeRight` Docs "docs\ndocs...\n" parse' "# docs" `shouldBeRight` Docs " docs\n" parse' "# docs\n# docs..." `shouldBeRight` Docs " docs\n docs...\n" it "may be mixed with whitespaces" $ do parse' "# docs\n\n# docs..." `shouldBeRight` Docs "docs\ndocs...\n" parse' "# docs\n # docs..." `shouldBeRight` Docs "docs\ndocs...\n" it "differs from comment" $ expectError "// comment" 1 1 let descTypeDecl label parser spec' = let parsers = [ (label, parser) , (label ++ " (typeDescription)", P.typeDeclaration) ] :: [(String, Parser TypeDeclaration)] in forM_ parsers $ \ (label', parser') -> describe label' $ spec' $ helperFuncs parser' describe "handleNameDuplication" $ do let cont dset = do _ <- string "a" return dset :: Parser (DeclarationSet SampleDecl) it "fails if there are any duplication on facial names" $ do let ds = [ "a" , "b" , SampleDecl (Name "b" "c") A.empty ] :: [SampleDecl] p = P.handleNameDuplication "LABEL" ds cont (parse', expectError) = helperFuncs p expectError "a" 1 1 let (Left e) = parse' "a" parseErrorPretty e `shouldBe` "1:1:\nthe facial LABEL name `b` is duplicated\n" it "fails if there are any duplication on behind names" $ do let ds = [ "a" , "b" , SampleDecl (Name "c" "b") A.empty ] :: [SampleDecl] p = P.handleNameDuplication "LABEL" ds cont (parse', expectError) = helperFuncs p expectError "a" 1 1 let (Left e) = parse' "a" parseErrorPretty e `shouldBe` "1:1:\nthe behind LABEL name `b` is duplicated\n" it "continues using the given DeclarationSet if there are no dups" $ do let ds = ["a", "b", "c"] :: [SampleDecl] p = P.handleNameDuplication "LABEL" ds cont (parse', _) = helperFuncs p parse' "a" `shouldBeRight` (["a", "b", "c"] :: DeclarationSet SampleDecl) descTypeDecl "aliasTypeDeclaration" P.aliasTypeDeclaration $ \ helpers -> do let (parse', expectError) = helpers it "emits (TypeDeclaration (Alias ...)) if succeeded to parse" $ do parse' "type path = text;" `shouldBeRight` TypeDeclaration "path" (Alias "text") empty parse' "type path = text;\n# docs" `shouldBeRight` TypeDeclaration "path" (Alias "text") (singleDocs "docs\n") parse' "type path = text;\n# docs\n# docs..." `shouldBeRight` TypeDeclaration "path" (Alias "text") (singleDocs "docs\ndocs...\n") parse' "@foo ( v = \"bar\" ) type path = text;\n# docs\n# docs..." `shouldBeRight` TypeDeclaration "path" (Alias "text") (A.union (singleDocs "docs\ndocs...\n") fooAnnotationSet) parse' "@baz type path = text;\n# docs\n# docs..." `shouldBeRight` TypeDeclaration "path" (Alias "text") (A.union (singleDocs "docs\ndocs...\n") bazAnnotationSet) specify ("its name can't have behind name since " ++ "its canonical type's behind name would be used instead") $ expectError "type path/error = text;" 1 10 it "fails to parse if trailing semicolon is missing" $ do let (_, expectErr) = helperFuncs P.module' expectErr "type a = text;\ntype b = text\ntype c = text;" 3 1 expectErr "unboxed a (text);\ntype b = text\nunboxed c (text);" 3 1 expectErr "type a = text;\nunboxed b (text)\ntype c = text;" 3 1 descTypeDecl "unboxedTypeDeclaration" P.unboxedTypeDeclaration $ \ funs -> do let (parse', expectError) = funs it "emits (TypeDeclaration (UnboxedType ..)) if succeeded to parse" $ do parse' "unboxed offset (float64);" `shouldBeRight` TypeDeclaration "offset" (UnboxedType "float64") empty parse' "unboxed offset (float64);\n# docs" `shouldBeRight` TypeDeclaration "offset" (UnboxedType "float64") (singleDocs "docs\n") parse' "unboxed offset (float64);\n# docs\n# docs..." `shouldBeRight` TypeDeclaration "offset" (UnboxedType "float64") (singleDocs "docs\ndocs...\n") parse' "@foo(v=\"bar\")\nunboxed offset (float64);\n# docs\n\ \# docs..." `shouldBeRight` TypeDeclaration "offset" (UnboxedType "float64") (A.union (singleDocs "docs\ndocs...\n") fooAnnotationSet) parse' "@baz\nunboxed offset (float64);\n# docs\n# docs..." `shouldBeRight` TypeDeclaration "offset" (UnboxedType "float64") (A.union (singleDocs "docs\ndocs...\n") bazAnnotationSet) expectError "unboxed offset/behind (float64);" 1 15 it "fails to parse if trailing semicolon is missing" $ do let (_, expectErr) = helperFuncs P.module' expectErr "unboxed a (text);\nunboxed b (text)\nunboxed c (text);" 3 1 expectErr "type a = text;\nunboxed b (text)\ntype c = text;" 3 1 expectErr "unboxed a (text);\ntype b = text\nunboxed c (text);" 3 1 descTypeDecl "enumTypeDeclaration" P.enumTypeDeclaration $ \ helpers -> do let (parse', expectError) = helpers it "emits (TypeDeclaration (EnumType ...)) if succeeded to parse" $ do let members' = [ "male" , "female" , "unknown" ] :: DeclarationSet EnumMember membersWithDocs = [ EnumMember "male" (singleDocs "docs\n") , "female" , EnumMember "unknown" (singleDocs "docs2\n") ] :: DeclarationSet EnumMember membersWithAnnots = [ EnumMember "male" fooAnnotationSet , "female" , "unknown" ] :: DeclarationSet EnumMember expected = TypeDeclaration "gender" (EnumType members') empty parse' "enum gender = male | female | unknown;" `shouldBeRight` expected parse' "enum gender=male|female|unknown;" `shouldBeRight` expected -- forward docs of enum type parse' "enum gender\n# gender type\n= male | female | unknown;" `shouldBeRight` expected { typeAnnotations = singleDocs "gender type\n" } -- backward docs of enum type parse' "enum gender =\n# gender type\nmale | female | unknown;" `shouldBeRight` expected { typeAnnotations = singleDocs "gender type\n" } parse' "enum gender = male # docs\n| female | unknown # docs2\n;" `shouldBeRight` TypeDeclaration "gender" (EnumType membersWithDocs) empty parse' "@foo (v = \"bar\")\nenum gender=male|female|unknown;" `shouldBeRight` TypeDeclaration "gender" (EnumType members') fooAnnotationSet parse' "@baz\nenum gender=male|female|unknown;" `shouldBeRight` TypeDeclaration "gender" (EnumType members') bazAnnotationSet parse' "@baz\nenum gender=\n@foo (v=\"bar\")\nmale|female|unknown;" `shouldBeRight` TypeDeclaration "gender" (EnumType membersWithAnnots) bazAnnotationSet it "fails to parse if there are duplicated facial names" $ expectError [s| enum dup = a/b | b/c | a/d ;|] 4 10 it "fails to parse if there are duplicated behind names" $ expectError [s| enum dup = a/b | b/c | c/b ;|] 4 10 it "fails to parse if trailing semicolon is missing" $ do let (_, expectErr) = helperFuncs P.module' expectErr "enum a = x | y;\nenum b = x | y\nenum c = x | y;" 3 1 expectErr "unboxed a (text);\nenum b = x | y\nunboxed c (text);" 3 1 expectErr "enum a = x | y;\nunboxed b (text)\nenum c = x | y;" 3 1 descTypeDecl "recordTypeDeclaration" P.recordTypeDeclaration $ \ helpers -> do let (parse', expectError) = helpers it "emits (TypeDeclaration (RecordType ...)) if succeeded to parse" $ do let nameF = Field "name" "text" empty dobF = Field "dob" "date" (singleDocs "date of birth") genderF = Field "gender" "gender" empty fields' = [nameF, dobF, genderF] :: DeclarationSet Field record = RecordType fields' a = TypeDeclaration "person" record empty b = a { typeAnnotations = singleDocs "person record type" } -- without docs, last field with trailing comma parse' [s| record person ( text name, date dob, # date of birth gender gender, );|] `shouldBeRight` a -- without docs, last field without trailing comma parse' [s| record person ( text name, date dob, # date of birth gender gender );|] `shouldBeRight` a -- with docs, last field with trailing comma parse' [s| record person ( # person record type text name, date dob, # date of birth gender gender, );|] `shouldBeRight` b -- with docs, last field without trailing comma parse' [s| record person ( # person record type text name, date dob, # date of birth gender gender );|] `shouldBeRight` b -- without docs, last field with trailing comma, -- with annotation with single argument parse' [s| @foo(v = "bar") record person ( text name, date dob, # date of birth gender gender, );|] `shouldBeRight` TypeDeclaration "person" record fooAnnotationSet -- without docs, last field with trailing comma, -- with annotation without arguments parse' [s| @baz record person ( text name, date dob, # date of birth gender gender, );|] `shouldBeRight` TypeDeclaration "person" record bazAnnotationSet -- with docs, last field with trailing comma, -- and annotation without arguments parse' [s| @baz record person ( # person record type text name, date dob, # date of birth gender gender, );|] `shouldBeRight` TypeDeclaration "person" record (union bazAnnotationSet $ singleDocs "person record type") -- without docs, last field with trailing comma, -- and annotations on fields parse' [s| record person ( text name, @foo (v = "bar") date dob, # date of birth @baz gender gender, );|] `shouldBeRight` TypeDeclaration "person" (RecordType [ nameF , dobF { fieldAnnotations = union fooAnnotationSet $ singleDocs "date of birth" } , genderF { fieldAnnotations = bazAnnotationSet } ]) empty it "should have one or more fields" $ do expectError "record unit ();" 1 14 expectError "record unit (\n# docs\n);" 3 1 it "fails to parse if there are duplicated facial names" $ expectError [s| record dup ( text a/b, text b/c, text a/d, );|] 5 1 it "fails to parse if there are duplicated behind names" $ expectError [s| record dup ( text a/b, text b/c, text c/b, );|] 5 1 it "fails to parse if there's no space between field type and name" $ do expectError "record a (texta);" 1 16 expectError "record a (textb\n#docs\n);" 2 1 it "fails to parse if trailing semicolon is missing" $ do let (_, expectErr) = helperFuncs P.module' expectErr "record a (text x);\nrecord b (text y)\nrecord c (text z);" 3 1 expectErr "type a = text;\nrecord b (text x)\ntype c = text;" 3 1 expectErr "record a (text x);\ntype b = text\nrecord c (text y);" 3 1 descTypeDecl "unionTypeDeclaration" P.unionTypeDeclaration $ \ helpers -> do let (parse', expectError) = helpers it "emits (TypeDeclaration (UnionType ...)) if succeeded to parse" $ do let cOriginF = Field "origin" "point" empty cRadiusF = Field "radius" "offset" empty circleFields = [cOriginF, cRadiusF] rUpperLeftF = Field "upper-left" "point" empty rLowerRightF = Field "lower-right" "point" empty rectangleFields = [rUpperLeftF, rLowerRightF] circleTag = Tag "circle" circleFields empty rectTag = Tag "rectangle" rectangleFields empty noneTag = Tag "none" [] empty tags' = [circleTag, rectTag, noneTag] union' = UnionType tags' a = TypeDeclaration "shape" union' empty b = a { typeAnnotations = singleDocs "shape type" } parse' [s| union shape = circle (point origin, offset radius,) | rectangle (point upper-left, point lower-right,) | none ;|] `shouldBeRight` a parse' [s| union shape = circle ( point origin, offset radius, ) | rectangle ( point upper-left, point lower-right, ) | none ;|] `shouldBeRight` a parse' [s| union shape # shape type = circle (point origin, offset radius,) | rectangle (point upper-left, point lower-right,) | none ;|] `shouldBeRight` b parse' [s| @docs (docs = "shape type\n") union shape = circle (point origin, offset radius,) | rectangle (point upper-left, point lower-right,) | none ;|] `shouldBeRight` b parse' [s| union shape = circle (point origin, offset radius,) | rectangle (point upper-left, point lower-right,) | @foo (v = "bar") none ;|] `shouldBeRight` a { type' = union' { tags = [ circleTag , rectTag , Tag "none" [] fooAnnotationSet ] } } parse' [s| union shape = circle (point origin, offset radius,) # tag docs | rectangle ( # front docs point upper-left, point lower-right, ) | none ;|] `shouldBeRight` a { type' = union' { tags = [ circleTag { tagAnnotations = singleDocs "tag docs" } , rectTag { tagAnnotations = singleDocs "front docs" } , noneTag ] } } parse' [s| union shape = circle (point origin, offset radius,) | rectangle (point upper-left, point lower-right,) | none # tag docs ;|] `shouldBeRight` a { type' = union' { tags = [ circleTag, rectTag , noneTag { tagAnnotations = singleDocs "tag docs" } ] } } parse' [s| union shape = circle (point origin, @baz offset radius,) | rectangle (point upper-left, @foo (v = "bar") point lower-right,) | none ;|] `shouldBeRight` a { type' = union' { tags = [ circleTag { tagFields = [ cOriginF , cRadiusF { fieldAnnotations = bazAnnotationSet } ] } , rectTag { tagFields = [ rUpperLeftF , rLowerRightF { fieldAnnotations = fooAnnotationSet } ] } , noneTag ] } } it "fails to parse if there are duplicated facial names" $ do expectError [s| union dup = a/b | b/c | a/d ;|] 5 6 expectError [s| union dup = a (text a/b, text b/c, text a/d) | b ;|] 2 38 it "fails to parse if there are duplicated behind names" $ do expectError [s| union dup = a/b | b/c | c/b ;|] 5 6 expectError [s| union dup = a (text a/b, text b/c, text c/b) | b ;|] 2 38 it "fails to parse if trailing semicolon is missing" $ do let (_, expectErr) = helperFuncs P.module' expectErr "union a = x | y;\nunion b = x | y\nunion c = x | y;" 3 1 expectErr "unboxed a (text);\nunion b = x | y\nunboxed c (text);" 3 1 expectErr "union a = x | y;\nunboxed b (text)\nunion c = x | y;" 3 1 describe "method" $ do let (parse', expectError) = helperFuncs P.method httpGetAnnotation = singleton $ Annotation "http" [ ("method", "GET") , ("path", "/get-name/") ] it "emits Method if succeeded to parse" $ do parse' "text get-name()" `shouldBeRight` Method "get-name" [] (Just "text") Nothing empty parse' "text get-name (person user)" `shouldBeRight` Method "get-name" [Parameter "user" "person" empty] (Just "text") Nothing empty parse' "text get-name ( person user,text default )" `shouldBeRight` Method "get-name" [ Parameter "user" "person" empty , Parameter "default" "text" empty ] (Just "text") Nothing empty parse' "@http(method = \"GET\", path = \"/get-name/\") \ \text get-name ( person user,text default )" `shouldBeRight` Method "get-name" [ Parameter "user" "person" empty , Parameter "default" "text" empty ] (Just "text") Nothing httpGetAnnotation parse' "text get-name() throws name-error" `shouldBeRight` Method "get-name" [] (Just "text") (Just "name-error") empty parse' [s| text get-name ( person user,text default ) throws get-name-error|] `shouldBeRight` Method "get-name" [ Parameter "user" "person" empty , Parameter "default" "text" empty ] (Just "text") (Just "get-name-error") empty parse' [s| @http(method = "GET", path = "/get-name/") text get-name ( person user,text default ) throws get-name-error|] `shouldBeRight` Method "get-name" [ Parameter "user" "person" empty , Parameter "default" "text" empty ] (Just "text") (Just "get-name-error") httpGetAnnotation parse' "get-name()" `shouldBeRight` Method "get-name" [] Nothing Nothing empty parse' "get-name() throws name-error" `shouldBeRight` Method "get-name" [] Nothing (Just "name-error") empty it "can have docs" $ do parse' [s| text get-name ( # Gets the name. )|] `shouldBeRight` Method "get-name" [] (Just "text") Nothing (singleDocs "Gets the name.") parse' [s| text get-name ( # Gets the name. )throws name-error |] `shouldBeRight` Method "get-name" [] (Just "text") (Just "name-error") (singleDocs "Gets the name.") parse' [s| text get-name ( # Gets the name of the user. person user, )|] `shouldBeRight` Method "get-name" [Parameter "user" "person" empty] (Just "text") Nothing (singleDocs "Gets the name of the user.") parse' [s| text get-name ( # Gets the name of the user. person user, ) throws get-name-error|] `shouldBeRight` Method "get-name" [Parameter "user" "person" empty] (Just "text") (Just "get-name-error") (singleDocs "Gets the name of the user.") let expectedUserPDocs = "The person to find their name." expectedDefaultPDocs = "The default name used when the user has no name." expectedMethod = Method "get-name" [ Parameter "user" "person" $ singleDocs expectedUserPDocs , Parameter "default" "text" $ singleDocs expectedDefaultPDocs ] (Just "text") Nothing (singleDocs "Gets the name of the user.") parse' [s| text get-name ( # Gets the name of the user. person user, # The person to find their name. text default # The default name used when the user has no name. )|] `shouldBeRight` expectedMethod it "fails to parse if there are parameters of the same facial name" $ do expectError "bool pred(text a, text a/b)" 1 11 expectError "bool pred(text a/b, text a)" 1 11 expectError "bool pred(text c/a, text c/b)" 1 11 it "fails to parse if there are parameters of the same behind name" $ do expectError "bool pred(text a, text b/a)" 1 11 expectError "bool pred(text a/b, text b)" 1 11 expectError "bool pred(text a/c, text b/c)" 1 11 describe "serviceDeclaration" $ do let (parse', expectError) = helperFuncs P.serviceDeclaration getUserD = singleDocs "Gets an user by its id." createUserD = singleDocs "Creates a new user" noMethodsD = singleDocs "Service having no methods." oneMethodD = singleDocs "Service having only one method." multiMethodsD = singleDocs "Service having multiple methods." userIdD = singleDocs "The unique user identifier." it "emits ServiceDeclaration if succeeded to parse" $ do parse' "service null-service();" `shouldBeRight` ServiceDeclaration "null-service" (Service []) empty parse' [s| service null-service ( # Service having no methods. );|] `shouldBeRight` ServiceDeclaration "null-service" (Service []) noMethodsD parse' [s| service one-method-service( user get-user(uuid user-id) );|] `shouldBeRight` ServiceDeclaration "one-method-service" (Service [ Method "get-user" [Parameter "user-id" "uuid" empty] (Just "user") Nothing empty ]) empty parse' [s| service one-method-service ( # Service having only one method. user get-user ( # Gets an user by its id. uuid user-id ) throws get-user-error, );|] `shouldBeRight` ServiceDeclaration "one-method-service" (Service [ Method "get-user" [Parameter "user-id" "uuid" empty] (Just "user") (Just "get-user-error") getUserD ]) oneMethodD parse' [s| service user-service ( # Service having multiple methods. user create-user ( # Creates a new user user user ), user get-user ( # Gets an user by its id. uuid user-id ), );|] `shouldBeRight` ServiceDeclaration "user-service" (Service [ Method "create-user" [Parameter "user" "user" empty] (Just "user") Nothing createUserD , Method "get-user" [Parameter "user-id" "uuid" empty] (Just "user") Nothing getUserD ]) multiMethodsD parse' [s| @foo(v = "bar") service null-service ( # Service having no methods. );|] `shouldBeRight` ServiceDeclaration "null-service" (Service []) (A.union noMethodsD fooAnnotationSet) parse' [s| @baz service null-service ( # Service having no methods. );|] `shouldBeRight` ServiceDeclaration "null-service" (Service []) (A.union noMethodsD bazAnnotationSet) parse' [s| service user-service ( @docs (docs = "Creates a new user\n") user create-user ( user user ), @docs (docs = "Gets an user by its id.\n") user get-user ( uuid user-id ), );|] `shouldBeRight` ServiceDeclaration "user-service" (Service [ Method "create-user" [Parameter "user" "user" empty] (Just "user") Nothing createUserD , Method "get-user" [Parameter "user-id" "uuid" empty] (Just "user") Nothing getUserD ]) empty parse' [s| service user-service ( user get-user ( @baz uuid user-id # The unique user identifier. ), );|] `shouldBeRight` ServiceDeclaration "user-service" (Service [ Method "get-user" [ Parameter "user-id" "uuid" $ A.union bazAnnotationSet userIdD ] (Just "user") Nothing empty ]) empty it "fails to parse if there are methods of the same facial name" $ do expectError [s| service method-dups ( bool same-name () text same-name (uuid id) );|] 3 3 expectError [s| service method-dups ( bool same-name () text same-name/different-behind-name (uuid id) );|] 3 3 expectError [s| service method-dups ( bool same-name/unique-behind-name () text same-name/different-behind-name (uuid id) );|] 3 3 it "fails to parse if there are methods of the same behind name" $ do expectError [s| service method-dups ( bool same-name () text same-name (uuid id) );|] 3 3 expectError [s| service method-dups ( bool same-name () text unique-name/same-name (uuid id) );|] 3 3 expectError [s| service method-dups ( bool unique-name/same-name () text different-facial-name/same-name (uuid id) );|] 3 3 it "fails to parse if trailing semicolon is missing" $ do let (_, expectErr) = helperFuncs P.module' expectErr "service a ();\nservice b ()\nservice c ();" 3 1 expectErr "type a = text;\nservice b ()\ntype c = text;" 3 1 expectErr "service a ();\ntype b = text\nservice c ();" 3 1 let moduleParsers = [ ("module'", P.module') , ("file", P.file) ] :: [(String, Parser Module)] forM_ moduleParsers $ \ (label, parser') -> describe label $ do let (parse', expectError) = helperFuncs parser' it "emits Module if succeeded to parse" $ do let decls = [ TypeDeclaration "path" (Alias "text") empty , TypeDeclaration "offset" (UnboxedType "float64") empty ] parse' "type path = text; unboxed offset (float64);" `shouldBeRight` Module decls Nothing parse' "#docs\n#...\ntype path = text; unboxed offset (float64);" `shouldBeRight` Module decls (Just "docs\n...") it "may have no type declarations" $ do parse' "" `shouldBeRight` Module [] Nothing parse' "# docs" `shouldBeRight` Module [] (Just "docs") it "errors if there are any duplicated facial names" $ expectError "type a = text;\ntype a/b = text;" 2 7 it "errors if there are any duplicated behind names" $ expectError "type b = text;\ntype a/b = text;" 2 7 describe "modulePath" $ do let (parse', expectError) = helperFuncs P.modulePath it "emits ModulePath if succeeded to parse" $ do parse' "foo" `shouldBeRight` ["foo"] parse' "foo.bar" `shouldBeRight` ["foo", "bar"] parse' "foo.bar.baz" `shouldBeRight` ["foo", "bar", "baz"] it "errors if it's empty" $ expectError "" 1 1 it "errors if it starts with period" $ do expectError "." 1 1 expectError ".foo" 1 1 expectError ".foo.bar" 1 1 expectError ".foo.bar.baz" 1 1 it "errors if it ends with period" $ do expectError "." 1 1 expectError "foo." 1 5 expectError "foo.bar." 1 9 expectError "foo.bar.baz." 1 13 describe "imports" $ do let (parse', expectError) = helperFuncs P.imports it "emits Import values if succeeded to parse" $ parse' "import foo.bar (a, b);" `shouldBeRight` [ Import ["foo", "bar"] "a" empty , Import ["foo", "bar"] "b" empty ] it "can be annotated" $ do parse' "import foo.bar (@foo (v = \"bar\") a, @baz b);" `shouldBeRight` [ Import ["foo", "bar"] "a" fooAnnotationSet , Import ["foo", "bar"] "b" bazAnnotationSet ] parse' "import foo.bar (@foo (v = \"bar\") @baz a, b);" `shouldBeRight` [ Import ["foo", "bar"] "a" $ union fooAnnotationSet bazAnnotationSet , Import ["foo", "bar"] "b" empty ] specify "import names can have a trailing comma" $ parse' "import foo.bar (a, b,);" `shouldBeRight` [ Import ["foo", "bar"] "a" empty , Import ["foo", "bar"] "b" empty ] specify "import names in parentheses can be multiline" $ do -- without a trailing comma parse' "import foo.bar (\n a,\n b\n);" `shouldBeRight` [ Import ["foo", "bar"] "a" empty , Import ["foo", "bar"] "b" empty ] -- with a trailing comma parse' "import foo.bar (\n c,\n d,\n);" `shouldBeRight` [ Import ["foo", "bar"] "c" empty , Import ["foo", "bar"] "d" empty ] it "errors if parentheses have nothing" $ expectError "import foo.bar ();" 1 17 specify "parse & parseFile" $ do files <- getDirectoryContents "examples" let examples = map ("examples/" ++) $ filter (isSuffixOf ".nrm") files forM_ examples $ \ filePath -> do sourceCode <- B.readFile filePath let parseResult = P.parse (filePath ++ " (text)") (E.decodeUtf8 sourceCode) parseResult `shouldSatisfy` isRight let Right module' = parseResult P.parse (filePath ++ " (text inverse)") (toCode module') `shouldBeRight` module' parseFileResult <- P.parseFile filePath parseFileResult `shouldSatisfy` isRight parseFileResult `shouldBe` parseResult {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}