nirum-0.4.0: test/Nirum/ParserSpec.hs
{-# 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