{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE 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 qualified Nirum.Parser as P import Nirum.Parser (Parser, ParseError) import Nirum.Constructs (Construct (toCode)) import Nirum.Constructs.Annotation as A import Nirum.Constructs.Annotation.Internal hiding (Text) import qualified Nirum.Constructs.Annotation.Internal as AI import Nirum.Constructs.Docs (Docs (Docs)) import Nirum.Constructs.DeclarationSet (DeclarationSet) import Nirum.Constructs.DeclarationSetSpec (SampleDecl (..)) import Nirum.Constructs.Identifier (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 as TD hiding (tags) 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 ParseError a -> (Pos, Pos) erroredPos left = (sourceLine pos, sourceColumn pos) where error' = head $ lefts [left] :: ParseError pos = NE.head (errorPos error') :: SourcePos helperFuncs :: (Show a) => Parser a -> ( T.Text -> Either 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 let parseResult = parse' inputString line' = mkPos line col' = mkPos col 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", AI.Text "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", AI.Text "wo\"rld")] let rightIntAnnotation = Annotation "name-abc" [("foo", Integer 1)] 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", AI.Text "wo\"rld\n")] parse' "@name-abc(foo=1)" `shouldBeRight` rightIntAnnotation parse' "@name-abc( foo=1)" `shouldBeRight` rightIntAnnotation parse' "@name-abc(foo=1 )" `shouldBeRight` rightIntAnnotation parse' "@name-abc( foo=1 )" `shouldBeRight` rightIntAnnotation 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", AI.Text "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, [Identifier] -> 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 = a1 | a2;\nenum b = b1 | y\nenum c = c1 | c2;" 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 = c1 | c2;" 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 "has defaultTag" $ 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 tags' = [circleTag] Right union' = unionType tags' $ Just rectTag a = TypeDeclaration "shape" union' empty parse' [s| union shape = circle (point origin, offset radius,) | default rectangle (point upper-left, point lower-right,) ;|] `shouldBeRight` a 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] Right union' = unionType tags' Nothing 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 let Right union3 = unionType [circleTag, rectTag, Tag "none" [] fooAnnotationSet] Nothing parse' [s| union shape = circle (point origin, offset radius,) | rectangle (point upper-left, point lower-right,) | @foo (v = "bar") none ;|] `shouldBeRight` a { type' = union3 } let Right union4 = unionType [ circleTag { tagAnnotations = singleDocs "tag docs" } , rectTag { tagAnnotations = singleDocs "front docs" } , noneTag ] Nothing parse' [s| union shape = circle (point origin, offset radius,) # tag docs | rectangle ( # front docs point upper-left, point lower-right, ) | none ;|] `shouldBeRight` a { type' = union4 } let Right union5 = unionType [ circleTag, rectTag , noneTag { tagAnnotations = singleDocs "tag docs" } ] Nothing parse' [s| union shape = circle (point origin, offset radius,) | rectangle (point upper-left, point lower-right,) | none # tag docs ;|] `shouldBeRight` a { type' = union5 } let Right union6 = unionType [ circleTag { tagFields = [ cOriginF , cRadiusF { fieldAnnotations = bazAnnotationSet } ] } , rectTag { tagFields = [ rUpperLeftF , rLowerRightF { fieldAnnotations = fooAnnotationSet } ] } , noneTag ] Nothing parse' [s| union shape = circle (point origin, @baz offset radius,) | rectangle (point upper-left, @foo (v = "bar") point lower-right,) | none ;|] `shouldBeRight` a { type' = union6 } 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 = a1 | a2;\nunion b = b1 | b2\nunion c = c1 | c2;" 3 1 expectErr "unboxed a (text);\nunion b = x | y\nunboxed c (text);" 3 1 expectErr "union a = a1 | a2;\nunboxed b (text)\nunion c = c1 | c2;" 3 1 it "failed to parse union with more than 1 default keyword." $ do let (_, expectErr) = helperFuncs P.module' expectErr [s| union shape = default circle (point origin, offset radius,) | default rectangle (point upper-left, point lower-right,) ;|] 4 6 describe "method" $ do let (parse', expectError) = helperFuncs P.method httpGetAnnotation = singleton $ Annotation "http" [ ("method", AI.Text "GET") , ("path", AI.Text "/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 6 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 "can single import name w/o trailing comma" $ do parse' "import foo.bar (a);" `shouldBeRight` [Import ["foo", "bar"] "a" "a" empty] parse' "import foo.bar (a as qux);" `shouldBeRight` [Import ["foo", "bar"] "qux" "a" empty] it "can single import name w/ trailing comma" $ do parse' "import foo.bar (a,);" `shouldBeRight` [Import ["foo", "bar"] "a" "a" empty] parse' "import foo.bar (a as qux,);" `shouldBeRight` [Import ["foo", "bar"] "qux" "a" empty] it "emits Import values if succeeded to parse" $ do parse' "import foo.bar (a, b);" `shouldBeRight` [ Import ["foo", "bar"] "a" "a" empty , Import ["foo", "bar"] "b" "b" empty ] parse' "import foo.bar (a as foo, b as bar);" `shouldBeRight` [ Import ["foo", "bar"] "foo" "a" empty , Import ["foo", "bar"] "bar" "b" empty ] it "can be annotated" $ do parse' "import foo.bar (@foo (v = \"bar\") a, @baz b);" `shouldBeRight` [ Import ["foo", "bar"] "a" "a" fooAnnotationSet , Import ["foo", "bar"] "b" "b" bazAnnotationSet ] parse' "import foo.bar (@foo (v = \"bar\") @baz a, b);" `shouldBeRight` [ Import ["foo", "bar"] "a" "a" $ union fooAnnotationSet bazAnnotationSet , Import ["foo", "bar"] "b" "b" empty ] parse' "import foo.bar (@foo (v = \"bar\") a as foo, @baz b as bar);" `shouldBeRight` [ Import ["foo", "bar"] "foo" "a" fooAnnotationSet , Import ["foo", "bar"] "bar" "b" bazAnnotationSet ] parse' "import foo.bar (@foo (v = \"bar\") @baz a as foo, b as bar);" `shouldBeRight` [ Import ["foo", "bar"] "foo" "a" $ union fooAnnotationSet bazAnnotationSet , Import ["foo", "bar"] "bar" "b" empty ] specify "import names can have a trailing comma" $ do parse' "import foo.bar (a, b,);" `shouldBeRight` [ Import ["foo", "bar"] "a" "a" empty , Import ["foo", "bar"] "b" "b" empty ] parse' "import foo.bar (a as foo, b as bar,);" `shouldBeRight` [ Import ["foo", "bar"] "foo" "a" empty , Import ["foo", "bar"] "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" "a" empty , Import ["foo", "bar"] "b" "b" empty ] parse' "import foo.bar (\n a as foo,\n b as bar\n);" `shouldBeRight` [ Import ["foo", "bar"] "foo" "a" empty , Import ["foo", "bar"] "bar" "b" empty ] -- with a trailing comma parse' "import foo.bar (\n c,\n d,\n);" `shouldBeRight` [ Import ["foo", "bar"] "c" "c" empty , Import ["foo", "bar"] "d" "d" empty ] parse' "import foo.bar (\n c as foo,\n d as bar,\n);" `shouldBeRight` [ Import ["foo", "bar"] "foo" "c" empty , Import ["foo", "bar"] "bar" "d" empty ] it "errors if parentheses have nothing" $ expectError "import foo.bar ();" 1 17 it "disallows when there are duplicated alias names" $ expectError "import foo.bar (lorem as yolo, ipsum as yolo);" 1 41 describe "module'" $ do context "handling name duplications" $ do let (_, expectError) = helperFuncs P.module' let examples = -- Vertical alignment of `dup` is an intention; it purposes -- to generate the same error offsets. [ "type dup = text;" , "unboxed dup (text);" , "record dup (text a);" , "enum dup = m1 | m2;" , "enum e1 = dup | foo;" , "union dup = t1 | t2;" , "union u1 = dup | foo;" , "service dup (text ping ());" ] let importExample = "import foo (dup);" let shiftDigit = \ case '1' -> '3' '2' -> '4' c -> c let inputs = [ (a, if a == b then T.map shiftDigit b else b) | a <- importExample : examples , b <- examples ] forM_ inputs $ \ (forward, shadowing) -> let input = T.concat [forward, "\n", shadowing] in specify (T.unpack input) $ expectError input 2 12 specify "allows import duplicated source name when it use alias" $ do let (parse', _) = helperFuncs P.module' parse' "import foo.bar (a);\n import lorem.ipsum (a as dolor);" `shouldBeRight` Module [ Import ["foo", "bar"] "a" "a" empty , Import ["lorem", "ipsum"] "dolor" "a" empty ] Nothing 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