diff options
Diffstat (limited to 'test')
| -rw-r--r-- | test/qsp_parser_test.ml | 832 | ||||
| -rw-r--r-- | test/syntax.ml | 832 | ||||
| -rw-r--r-- | test/syntax_error.ml | 85 |
3 files changed, 918 insertions, 831 deletions
diff --git a/test/qsp_parser_test.ml b/test/qsp_parser_test.ml index 652ef75..cbbe91e 100644 --- a/test/qsp_parser_test.ml +++ b/test/qsp_parser_test.ml @@ -1,831 +1 @@ -module Parser = Qparser.Parser.Make (Qsp_syntax.Tree) -module Tree = Qsp_syntax.Tree -module Ast = Qsp_syntax.Tree.Ast -module T = Ast - -let _position = (Lexing.dummy_pos, Lexing.dummy_pos) - -type 'a location = 'a * 'a Ast.statement list [@@deriving eq, show] - -(** Run the parser with the given expression and return the result *) -let parse : string -> T.pos location = - fun content -> - let lexing = - Sedlexing.Latin1.from_string content |> Qparser.Lexbuf.from_lexbuf - in - match Qparser.Analyzer.parse (module Qsp_syntax.Tree) lexing with - | Ok e -> e - | Error e -> - let msg = Format.asprintf "%a" Qsp_syntax.Report.pp e in - raise (Failure msg) - -let location : T.pos location Alcotest.testable = - let equal = equal_location (fun _ _ -> true) in - let pp = - pp_location (fun formater _ -> Format.fprintf formater "_position") - in - Alcotest.testable pp equal - -let test_empty_location () = - let expected = (_position, []) - and actual = parse {|# Location -------- |} - and msg = "Empty location" in - - Alcotest.(check' location ~msg ~expected ~actual) - -let test_location_without_database () = - let expected = (_position, []) - and actual = parse {|# $Location -------- |} - and msg = "Location without database" in - - let () = Alcotest.(check' location ~msg ~expected ~actual) in - - let actual = parse {|# !Location -------- |} in - let () = Alcotest.(check' location ~msg ~expected ~actual) in - - let actual = parse {|# ^Location -------- |} in - Alcotest.(check' location ~msg ~expected ~actual) - -let _test_instruction : string -> Ast.pos Ast.statement list -> unit = - fun literal expected -> - let expected = (_position, expected) - and _location = Printf.sprintf {|# Location -%s -------- |} literal in - let actual = parse _location and msg = literal in - - Alcotest.(check' location ~msg ~expected ~actual) - -let test_numeric_expression () = - _test_instruction "123" [ Expression (Integer (_position, "123")) ] - -let test_negative_numeric_expression () = - _test_instruction "-123" - [ Expression (Op (_position, Neg, Integer (_position, "123"))) ] - -let test_negative_numeric_expression2 () = - let index = None in - let var = { Ast.pos = _position; name = "CURTIMESUN"; index } in - _test_instruction "-(780-CurTimeSun)" - Ast. - [ - Expression - (Op - ( _position, - Neg, - BinaryOp (_position, Minus, Integer (_position, "780"), Ident var) - )); - ] - -let test_str_variable () = - let index = None in - let var = { Ast.pos = _position; name = "$VALUE"; index } in - _test_instruction "$value" [ Expression (Ident var) ] - -let test_variable () = - let index = None in - let var = { Ast.pos = _position; name = "VALUE"; index } in - _test_instruction "value" [ Expression (Ident var) ] - -let test_indexed_variable () = - let index = Some Ast.(Integer (_position, "1")) in - let var = { Ast.pos = _position; name = "VALUE"; index } in - _test_instruction "value[1]" [ Expression (Ident var) ] - -let test_let_literal () = - let index = None in - let var = { Ast.pos = _position; name = "VALUE"; index } in - _test_instruction "let value = '123'" - Ast.[ Declaration (_position, var, Eq', Literal (_position, "123")) ] - -let test_set_array_append () = - let var = { Ast.pos = _position; name = "$VALUE"; index = None } in - _test_instruction "set $value[] = ''" - Ast.[ Declaration (_position, var, Eq', Literal (_position, "")) ] - -let test_direct_assignation () = - let index = None in - let var = { T.pos = _position; name = "VALUE"; index } in - _test_instruction "value = '123'" - Ast.[ Declaration (_position, var, Eq', Literal (_position, "123")) ] - -let test_command_assignation () = - let index = None in - let st_1 = { Ast.pos = _position; name = "ST_1"; index } in - _test_instruction "st_1 = input 'Enter the amount'" - Ast. - [ - Declaration - ( _position, - st_1, - Eq', - Function - (_position, Input, [ Literal (_position, "Enter the amount") ]) ); - ] - -let test_assignation2 () = - let index = None in - let var = { Ast.pos = _position; name = "VALUE"; index } in - _test_instruction "set value += 123" - Ast.[ Declaration (_position, var, Inc, Integer (_position, "123")) ] - -let test_multilie_literal () = - let index = None in - let var = { Ast.pos = _position; name = "VALUE"; index } in - _test_instruction {| - value = { -$a = '123' -}|} - Ast. - [ - Declaration (_position, var, Eq', Literal (_position, "\n$a = '123'\n")); - ] - -let test_nested_literal () = - _test_instruction - {| - value = { - - { - - } -}|} - [ - Ast.Declaration - ( _position, - { Ast.pos = _position; name = "VALUE"; index = None }, - Qsp_syntax.T.Eq', - Ast.Literal (_position, "\n\n {\n\n }\n") ); - ] - -let test_concat_literal () = - _test_instruction {| - '123' - +'456' -|} - [ - Ast.Expression (Ast.Literal (_position, "123")); - Ast.Expression - (Ast.Op (_position, Qsp_syntax.T.Add, Ast.Literal (_position, "456"))); - ] - -let test_literal () = - _test_instruction "'123'" [ Expression (Literal (_position, "123")) ] - -let test_qutoted_literal () = - _test_instruction "'12''3'" [ Expression (Literal (_position, "12'3")) ] - -let test_multiline1 () = - let content = {| -apples = 5 -pears = 10 -|} in - - let index = None in - let apples = { Ast.pos = _position; name = "APPLES"; index } - and pears = { Ast.pos = _position; name = "PEARS"; index } - and value_5 = Ast.Integer (_position, "5") - and value_10 = Ast.Integer (_position, "10") in - _test_instruction content - Ast. - [ - Declaration (_position, apples, Eq', value_5); - Declaration (_position, pears, Eq', value_10); - ] - -let test_multiline2 () = - let content = "apples = 5 & pears = 10" in - - let index = None in - let apples = { Ast.pos = _position; name = "APPLES"; index } - and pears = { Ast.pos = _position; name = "PEARS"; index } - and value_5 = Ast.Integer (_position, "5") - and value_10 = Ast.Integer (_position, "10") in - _test_instruction content - [ - Declaration (_position, apples, Eq', value_5); - Declaration (_position, pears, Eq', value_10); - ] - -let test_equality () = - let content = "apples = 5 = pears" in - let index = None in - let apples = { Ast.pos = _position; name = "APPLES"; index } - and pears = { Ast.pos = _position; name = "PEARS"; index } - and value_5 = Ast.Integer (_position, "5") in - _test_instruction content - [ - Declaration - (_position, apples, Eq', BinaryOp (_position, Eq, value_5, Ident pears)); - ] - -let test_plus () = - let content = {| -apples = 5 + pears -|} in - let index = None in - let apples = { Ast.pos = _position; name = "APPLES"; index } - and pears = { Ast.pos = _position; name = "PEARS"; index } - and value_5 = Ast.Integer (_position, "5") in - _test_instruction content - [ - Declaration - ( _position, - apples, - Eq', - BinaryOp (_position, Plus, value_5, Ident pears) ); - ] - -let test_plus_litt () = - let content = {| -'five'+ pears -|} in - let index = None in - let pears = { Ast.pos = _position; name = "PEARS"; index } in - _test_instruction content - [ - Ast.( - Expression - (BinaryOp (_position, Plus, Literal (_position, "five"), Ident pears))); - ] - -let test_concat () = - let content = {| -$firstName + ' ' + $lastName -|} in - _test_instruction content - [ - Tree.Ast.Expression - (Tree.Ast.BinaryOp - ( _position, - Plus, - Tree.Ast.BinaryOp - ( _position, - Plus, - Tree.Ast.Ident - { - Tree.Ast.pos = _position; - name = "$FIRSTNAME"; - index = None; - }, - Tree.Ast.Literal (_position, " ") ), - Tree.Ast.Ident - { Tree.Ast.pos = _position; name = "$LASTNAME"; index = None } )); - ] - -let test_comment () = _test_instruction "! Comment" [ Comment _position ] - -let test_comment2 () = - let index = None in - let a = { Ast.pos = _position; name = "A"; index } - and value_0 = Ast.Integer (_position, "0") in - _test_instruction "a = 0 &! Comment" - Ast.[ Declaration (_position, a, Eq', value_0); Comment _position ] - -let test_comment3 () = _test_instruction {|!!1234 - |} [ Comment _position ] - -(** The exclamation mark here is an operation and not a comment *) -let test_comment4 () = - let index = None in - let a = { Ast.pos = _position; name = "A"; index } - and value_0 = Ast.Integer (_position, "0") in - _test_instruction "a = rand(0, 1) ! 0" - [ - Ast.( - Declaration - ( _position, - a, - Eq', - BinaryOp - ( _position, - Neq, - Function - ( _position, - Rand, - [ Integer (_position, "0"); Integer (_position, "1") ] ), - value_0 ) )); - ] - -let test_comment5 () = - _test_instruction "a = rand() &! Comment" - [ - Ast.Declaration - ( _position, - { Ast.pos = _position; name = "A"; index = None }, - Qsp_syntax.T.Eq', - Ast.Function (_position, Rand, []) ); - Ast.Comment _position; - ] - -let test_comment6 () = - _test_instruction - "gs 'stat' &!! It should be here, because some of the strigs have to be \ - initialized" - [ - Ast.Call (_position, "GOSUB", [ Ast.Literal (_position, "stat") ]); - Ast.Comment _position; - ] - -let test_long_comment () = - _test_instruction - {| !'this part of the comment is inside -single quotes' but "this is still part -of the same comment because sometimes -life is unfair." Oh yeah, {curly brackets -also count}. This is still the same comment. |} - [ Comment _position ] - -(** This test ensure that the unary operator is applied to the whole expression - *) -let test_precedence () = - let index = None in - let x = Ast.Ident { Ast.pos = _position; name = "X"; index } - and y = Ast.Ident { Ast.pos = _position; name = "Y"; index } in - _test_instruction "no x = y" - Ast.[ Expression (Op (_position, No, BinaryOp (_position, Eq, x, y))) ] - -(** This test ensure that a ! is not considered as a comment in an - expression *) -let test_precedence2 () = - let index = None in - let x = { Ast.pos = _position; name = "X"; index } - and y = Ast.Ident { Ast.pos = _position; name = "Y"; index } in - _test_instruction "x = y ! 0" - Ast. - [ - Declaration - ( _position, - x, - Eq', - BinaryOp (_position, Neq, y, Integer (_position, "0")) ); - ] - -let test_if () = - let index = Some Ast.(Integer (_position, "0")) in - let args = Ast.(Ident { pos = _position; name = "$ARGS"; index }) - and expr1 = Ast.(Literal (_position, "blockA")) - and expr2 = Ast.(Expression (Literal (_position, "You are in block A"))) in - _test_instruction {| if $ARGS[0] = 'blockA': - 'You are in block A' -end |} - Ast. - [ - If - { - loc = _position; - then_ = (_position, BinaryOp (_position, Eq, args, expr1), [ expr2 ]); - elifs = []; - else_ = []; - }; - ] - -let test_if2 () = - let index = Some Ast.(Integer (_position, "0")) in - let args = Ast.(Ident { pos = _position; name = "$ARGS"; index }) - and expr1 = Ast.(Literal (_position, "blockA")) - and expr2 = Ast.(Expression (Literal (_position, "You are in block A"))) in - _test_instruction {| if $ARGS[0] = 'blockA': - 'You are in block A' -end if|} - Ast. - [ - If - { - loc = _position; - then_ = (_position, BinaryOp (_position, Eq, args, expr1), [ expr2 ]); - elifs = []; - else_ = []; - }; - ] - -let test_if_chained () = - let value_0 = Ast.Integer (_position, "0") in - _test_instruction {| if 0: - 0 -end &! -- |} - Ast. - [ - If - { - loc = _position; - then_ = (_position, value_0, [ Expression value_0 ]); - elifs = []; - else_ = []; - }; - Comment _position; - ] - -let test_if_equality () = - _test_instruction {| -if 0 = 0: -end &! -- -|} - [ - Ast.If - { - loc = _position; - then_ = - ( _position, - Ast.BinaryOp - ( _position, - Qsp_syntax.T.Eq, - Ast.Integer (_position, "0"), - Ast.Integer (_position, "0") ), - [] ); - elifs = []; - else_ = []; - }; - Ast.Comment _position; - ] - -let test_if_inline () = - let value_0 = Ast.Integer (_position, "0") in - _test_instruction "if 0: 0 else 0" - Ast. - [ - If - { - loc = _position; - then_ = (_position, value_0, [ Expression value_0 ]); - elifs = []; - else_ = [ Expression value_0 ]; - }; - ] - -let test_if_inline_comment () = - let value_0 = Ast.Integer (_position, "0") in - _test_instruction "if 0: 0 else 0 &! comment " - Ast. - [ - If - { - loc = _position; - then_ = (_position, value_0, [ Expression value_0 ]); - elifs = []; - else_ = [ Expression value_0 ]; - }; - Comment _position; - ] - -let test_if_inline_comment2 () = - _test_instruction "if 0: 1 & !! Comment" - [ - Ast.If - { - loc = _position; - then_ = - ( _position, - Ast.Integer (_position, "0"), - [ - Ast.Expression (Ast.Integer (_position, "1")); - Ast.Comment _position; - ] ); - elifs = []; - else_ = []; - }; - ] - -let test_if_inline_act () = - _test_instruction "if 1 and hour >= 8: minut += 1 & act 'go': gt 'go'" - [ - Ast.If - { - loc = _position; - then_ = - ( _position, - Ast.BinaryOp - ( _position, - Qsp_syntax.T.And, - Ast.Integer (_position, "1"), - Ast.BinaryOp - ( _position, - Qsp_syntax.T.Gte, - Ast.Ident - { Ast.pos = _position; name = "HOUR"; index = None }, - Ast.Integer (_position, "8") ) ), - [ - Ast.Declaration - ( _position, - { Ast.pos = _position; name = "MINUT"; index = None }, - Qsp_syntax.T.Inc, - Ast.Integer (_position, "1") ); - Ast.Act - { - loc = _position; - label = Ast.Literal (_position, "go"); - statements = - [ - Ast.Call - (_position, "GOTO", [ Ast.Literal (_position, "go") ]); - ]; - }; - ] ); - elifs = []; - else_ = []; - }; - ] - -let test_if_inline_act2 () = - _test_instruction "if 1: act 'go': gt 'go' &! comment " - [ - Ast.If - { - loc = _position; - then_ = - ( _position, - Ast.Integer (_position, "1"), - [ - Ast.Act - { - loc = _position; - label = Ast.Literal (_position, "go"); - statements = - [ - Ast.Call - (_position, "GOTO", [ Ast.Literal (_position, "go") ]); - Ast.Comment _position; - ]; - }; - ] ); - elifs = []; - else_ = []; - }; - ] - -let test_precedence3 () = - let index = Some Ast.(Integer (_position, "0")) in - let args = Ast.(Ident { pos = _position; name = "$ARGS"; index }) - and expr1 = Ast.(Literal (_position, "blockA")) - and expr2 = Ast.(Expression (Literal (_position, "You are in block A"))) - and expr3 = Ast.(Expression (Integer (_position, "0"))) in - _test_instruction {| if $ARGS[0] = 'blockA': 'You are in block A' & 0|} - Ast. - [ - If - { - loc = _position; - then_ = - ( _position, - BinaryOp (_position, Eq, args, expr1), - [ expr2; expr3 ] ); - elifs = []; - else_ = []; - }; - ] - -let test_gs () = - _test_instruction "gs '123'" - [ Ast.(Call (_position, "GOSUB", [ Literal (_position, "123") ])) ] - -let test_gt () = - _test_instruction "gt $curloc" - [ - Ast.Call - ( _position, - "GOTO", - [ Ast.Ident { Ast.pos = _position; name = "$CURLOC"; index = None } ] - ); - ] - -let test_nl () = - _test_instruction "*NL 'It'" - [ Ast.Call (_position, "*NL", [ Ast.Literal (_position, "It") ]) ] - -let test_function () = - _test_instruction "iif(123, 1, 0)" - [ - Ast.( - Expression - (Function - ( _position, - Iif, - [ - Integer (_position, "123"); - Integer (_position, "1"); - Integer (_position, "0"); - ] ))); - ] - -(** Include a space before the parameters *) -let test_function2 () = - _test_instruction "rand (0, 1)" - [ - Ast.( - Expression - (Function - ( _position, - Rand, - [ Integer (_position, "0"); Integer (_position, "1") ] ))); - ] - -let test_precedence4 () = - _test_instruction "trim()" Ast.[ Expression (Function (_position, Trim, [])) ] - -(** This should not be a keyword without arguments, followed by an expression *) -let test_precedence5 () = - _test_instruction "clear()" Ast.[ Call (_position, "CLEAR", []) ] - -let test_precedence6 () = - _test_instruction "(1 = 0 and 2 ! 3)" - [ - Ast.Expression - (Ast.BinaryOp - ( _position, - And, - Ast.BinaryOp - ( _position, - Eq, - Ast.Integer (_position, "1"), - Ast.Integer (_position, "0") ), - Ast.BinaryOp - ( _position, - Neq, - Ast.Integer (_position, "2"), - Ast.Integer (_position, "3") ) )); - ] - -(** An identifier cannot start by a number *0 is a product and not an - identifier *) -let test_operator () = - let index = None in - let a = { Ast.pos = _position; name = "A"; index } - and value_0 = Ast.Integer (_position, "0") in - _test_instruction "a *0" - Ast.[ Expression (BinaryOp (_position, Product, Ident a, value_0)) ] - -let test_operator2 () = - let value_0 = Ast.Integer (_position, "0") in - _test_instruction "0 *rand()" - Ast. - [ - Expression - (BinaryOp (_position, Product, value_0, Function (_position, Rand, []))); - ] - -let test_dyneval () = - _test_instruction "dyneval ''" - [ - Ast.Expression - (Ast.Function (_position, Dyneval, [ Ast.Literal (_position, "") ])); - ] - -(** The parens after input are considered as arguments for the function, not a - following expression. - - This expression is a boolean. -*) -let test_input () = - _test_instruction "( input('') = '' )" - [ - Tree.Ast.Expression - (Tree.Ast.BinaryOp - ( _position, - Eq, - Tree.Ast.Function - (_position, Input, [ Tree.Ast.Literal (_position, "") ]), - Tree.Ast.Literal (_position, "") )); - ] - -let test_mutiple_inline_ifs () = - _test_instruction "if 1 > 0: 1 else if 1 < 0: 0" - [ - Tree.Ast.If - { - loc = _position; - then_ = - ( _position, - Tree.Ast.BinaryOp - ( _position, - Gt, - Tree.Ast.Integer (_position, "1"), - Tree.Ast.Integer (_position, "0") ), - [ Tree.Ast.Expression (Tree.Ast.Integer (_position, "1")) ] ); - elifs = []; - else_ = - [ - Tree.Ast.If - { - loc = _position; - then_ = - ( _position, - Tree.Ast.BinaryOp - ( _position, - Lt, - Tree.Ast.Integer (_position, "1"), - Tree.Ast.Integer (_position, "0") ), - [ - Tree.Ast.Expression (Tree.Ast.Integer (_position, "0")); - ] ); - elifs = []; - else_ = []; - }; - ]; - }; - ] - -let test_precedence7 () = - _test_instruction "(1 + 1 = '')" - [ - Tree.Ast.Expression - (Tree.Ast.BinaryOp - ( _position, - Eq, - Tree.Ast.BinaryOp - ( _position, - Plus, - Tree.Ast.Integer (_position, "1"), - Tree.Ast.Integer (_position, "1") ), - Tree.Ast.Literal (_position, "") )); - ] - -let test_precedence8 () = - _test_instruction "(0 = 1 or 0 = 1)" - [ - Tree.Ast.Expression - (Tree.Ast.BinaryOp - ( _position, - Or, - Tree.Ast.BinaryOp - ( _position, - Eq, - Tree.Ast.Integer (_position, "0"), - Tree.Ast.Integer (_position, "1") ), - Tree.Ast.BinaryOp - ( _position, - Eq, - Tree.Ast.Integer (_position, "0"), - Tree.Ast.Integer (_position, "1") ) )); - ] - -let syntax = - ( "Syntax", - [ - Alcotest.test_case "Location" `Quick test_empty_location; - Alcotest.test_case "Location" `Quick test_location_without_database; - Alcotest.test_case " Numeric expression" `Quick test_numeric_expression; - Alcotest.test_case "-Numeric expression" `Quick - test_negative_numeric_expression; - Alcotest.test_case "-Numeric expression2" `Quick - test_negative_numeric_expression2; - Alcotest.test_case "$Variable expression" `Quick test_str_variable; - Alcotest.test_case " Variable expression" `Quick test_variable; - Alcotest.test_case "Indexed Variable expression" `Quick - test_indexed_variable; - Alcotest.test_case "Let instruction" `Quick test_let_literal; - Alcotest.test_case "Set array_append" `Quick test_set_array_append; - Alcotest.test_case "Variable_assignation" `Quick test_direct_assignation; - Alcotest.test_case "Command assignation" `Quick test_command_assignation; - Alcotest.test_case "Variable_assignation2" `Quick test_assignation2; - Alcotest.test_case "Literal" `Quick test_literal; - Alcotest.test_case "Literal2" `Quick test_qutoted_literal; - Alcotest.test_case "Literal3" `Quick test_multilie_literal; - Alcotest.test_case "Concat Literal" `Quick test_concat_literal; - Alcotest.test_case "Nested Literal" `Quick test_nested_literal; - Alcotest.test_case "Multiline1" `Quick test_multiline1; - Alcotest.test_case "Multiline2" `Quick test_multiline2; - Alcotest.test_case "Equality" `Quick test_equality; - Alcotest.test_case "Plus" `Quick test_plus; - Alcotest.test_case "Plus_litt" `Quick test_plus_litt; - Alcotest.test_case "PlusChained" `Quick test_concat; - Alcotest.test_case "Comment" `Quick test_comment; - Alcotest.test_case "Comment2" `Quick test_comment2; - Alcotest.test_case "Comment3" `Quick test_comment3; - Alcotest.test_case "Comment4" `Quick test_comment4; - Alcotest.test_case "Comment5" `Quick test_comment5; - Alcotest.test_case "Comment6" `Quick test_comment6; - Alcotest.test_case "Multiline Comment" `Quick test_long_comment; - Alcotest.test_case "If" `Quick test_if; - Alcotest.test_case "If - end if" `Quick test_if2; - Alcotest.test_case "If_chained" `Quick test_if_chained; - Alcotest.test_case "If_equality" `Quick test_if_equality; - Alcotest.test_case "If inline" `Quick test_if_inline; - Alcotest.test_case "If inline &!" `Quick test_if_inline_comment; - Alcotest.test_case "If inline & !!" `Quick test_if_inline_comment2; - Alcotest.test_case "If : act" `Quick test_if_inline_act; - Alcotest.test_case "If : act: &!" `Quick test_if_inline_act2; - Alcotest.test_case "Precedence1" `Quick test_precedence; - Alcotest.test_case "Precedence2" `Quick test_precedence2; - Alcotest.test_case "Precedence3" `Quick test_precedence3; - Alcotest.test_case "Call gs" `Quick test_gs; - Alcotest.test_case "Call gt" `Quick test_gt; - Alcotest.test_case "Call nl" `Quick test_nl; - Alcotest.test_case "Function iif" `Quick test_function; - Alcotest.test_case "Function rand" `Quick test_function2; - Alcotest.test_case "Precedence4" `Quick test_precedence4; - Alcotest.test_case "Precedence5" `Quick test_precedence5; - Alcotest.test_case "Precedence6" `Quick test_precedence6; - Alcotest.test_case "Operator" `Quick test_operator; - Alcotest.test_case "Operator2" `Quick test_operator2; - Alcotest.test_case "Dyneval" `Quick test_dyneval; - Alcotest.test_case "Input" `Quick test_input; - Alcotest.test_case "inline if else if" `Quick test_mutiple_inline_ifs; - Alcotest.test_case "Precedence7" `Quick test_precedence7; - Alcotest.test_case "Precedence8" `Quick test_precedence8; - ] ) - -let () = Alcotest.run "qsp_parser" [ syntax ] +let () = Alcotest.run "qsp_parser" [ Syntax.test; Syntax_error.test ] diff --git a/test/syntax.ml b/test/syntax.ml new file mode 100644 index 0000000..8c6334e --- /dev/null +++ b/test/syntax.ml @@ -0,0 +1,832 @@ +module Parser = Qparser.Parser.Make (Qsp_syntax.Tree) +module Tree = Qsp_syntax.Tree +module Ast = Qsp_syntax.Tree.Ast +module T = Ast + +let _position = (Lexing.dummy_pos, Lexing.dummy_pos) + +type 'a location = 'a * 'a Ast.statement list [@@deriving eq, show] + +let get_location : + (T.pos location, Qsp_syntax.Report.t) result -> T.pos location = function + | Ok e -> e + | Error e -> + let msg = Format.asprintf "%a" Qsp_syntax.Report.pp e in + raise (Failure msg) + +(** Run the parser with the given expression and return the result *) +let parse : string -> (T.pos location, Qsp_syntax.Report.t) result = + fun content -> + let lexing = + Sedlexing.Latin1.from_string content |> Qparser.Lexbuf.from_lexbuf + in + Qparser.Analyzer.parse (module Qsp_syntax.Tree) lexing + +let location : T.pos location Alcotest.testable = + let equal = equal_location (fun _ _ -> true) in + let pp = + pp_location (fun formater _ -> Format.fprintf formater "_position") + in + Alcotest.testable pp equal + +let test_empty_location () = + let expected = (_position, []) + and actual = get_location @@ parse {|# Location +------- |} + and msg = "Empty location" in + + Alcotest.(check' location ~msg ~expected ~actual) + +let test_location_without_database () = + let expected = (_position, []) + and actual = get_location @@ parse {|# $Location +------- |} + and msg = "Location without database" in + + let () = Alcotest.(check' location ~msg ~expected ~actual) in + + let actual = get_location @@ parse {|# !Location +------- |} in + let () = Alcotest.(check' location ~msg ~expected ~actual) in + + let actual = get_location @@ parse {|# ^Location +------- |} in + Alcotest.(check' location ~msg ~expected ~actual) + +let _test_instruction : string -> Ast.pos Ast.statement list -> unit = + fun literal expected -> + let expected = (_position, expected) + and _location = Printf.sprintf {|# Location +%s +------- |} literal in + let actual = get_location @@ parse _location and msg = literal in + + Alcotest.(check' location ~msg ~expected ~actual) + +let test_numeric_expression () = + _test_instruction "123" [ Expression (Integer (_position, "123")) ] + +let test_negative_numeric_expression () = + _test_instruction "-123" + [ Expression (Op (_position, Neg, Integer (_position, "123"))) ] + +let test_negative_numeric_expression2 () = + let index = None in + let var = { Ast.pos = _position; name = "CURTIMESUN"; index } in + _test_instruction "-(780-CurTimeSun)" + Ast. + [ + Expression + (Op + ( _position, + Neg, + BinaryOp (_position, Minus, Integer (_position, "780"), Ident var) + )); + ] + +let test_str_variable () = + let index = None in + let var = { Ast.pos = _position; name = "$VALUE"; index } in + _test_instruction "$value" [ Expression (Ident var) ] + +let test_variable () = + let index = None in + let var = { Ast.pos = _position; name = "VALUE"; index } in + _test_instruction "value" [ Expression (Ident var) ] + +let test_indexed_variable () = + let index = Some Ast.(Integer (_position, "1")) in + let var = { Ast.pos = _position; name = "VALUE"; index } in + _test_instruction "value[1]" [ Expression (Ident var) ] + +let test_let_literal () = + let index = None in + let var = { Ast.pos = _position; name = "VALUE"; index } in + _test_instruction "let value = '123'" + Ast.[ Declaration (_position, var, Eq', Literal (_position, "123")) ] + +let test_set_array_append () = + let var = { Ast.pos = _position; name = "$VALUE"; index = None } in + _test_instruction "set $value[] = ''" + Ast.[ Declaration (_position, var, Eq', Literal (_position, "")) ] + +let test_direct_assignation () = + let index = None in + let var = { T.pos = _position; name = "VALUE"; index } in + _test_instruction "value = '123'" + Ast.[ Declaration (_position, var, Eq', Literal (_position, "123")) ] + +let test_command_assignation () = + let index = None in + let st_1 = { Ast.pos = _position; name = "ST_1"; index } in + _test_instruction "st_1 = input 'Enter the amount'" + Ast. + [ + Declaration + ( _position, + st_1, + Eq', + Function + (_position, Input, [ Literal (_position, "Enter the amount") ]) ); + ] + +let test_assignation2 () = + let index = None in + let var = { Ast.pos = _position; name = "VALUE"; index } in + _test_instruction "set value += 123" + Ast.[ Declaration (_position, var, Inc, Integer (_position, "123")) ] + +let test_multilie_literal () = + let index = None in + let var = { Ast.pos = _position; name = "VALUE"; index } in + _test_instruction {| + value = { +$a = '123' +}|} + Ast. + [ + Declaration (_position, var, Eq', Literal (_position, "\n$a = '123'\n")); + ] + +let test_nested_literal () = + _test_instruction + {| + value = { + + { + + } +}|} + [ + Ast.Declaration + ( _position, + { Ast.pos = _position; name = "VALUE"; index = None }, + Qsp_syntax.T.Eq', + Ast.Literal (_position, "\n\n {\n\n }\n") ); + ] + +let test_concat_literal () = + _test_instruction {| + '123' + +'456' +|} + [ + Ast.Expression (Ast.Literal (_position, "123")); + Ast.Expression + (Ast.Op (_position, Qsp_syntax.T.Add, Ast.Literal (_position, "456"))); + ] + +let test_literal () = + _test_instruction "'123'" [ Expression (Literal (_position, "123")) ] + +let test_qutoted_literal () = + _test_instruction "'12''3'" [ Expression (Literal (_position, "12'3")) ] + +let test_multiline1 () = + let content = {| +apples = 5 +pears = 10 +|} in + + let index = None in + let apples = { Ast.pos = _position; name = "APPLES"; index } + and pears = { Ast.pos = _position; name = "PEARS"; index } + and value_5 = Ast.Integer (_position, "5") + and value_10 = Ast.Integer (_position, "10") in + _test_instruction content + Ast. + [ + Declaration (_position, apples, Eq', value_5); + Declaration (_position, pears, Eq', value_10); + ] + +let test_multiline2 () = + let content = "apples = 5 & pears = 10" in + + let index = None in + let apples = { Ast.pos = _position; name = "APPLES"; index } + and pears = { Ast.pos = _position; name = "PEARS"; index } + and value_5 = Ast.Integer (_position, "5") + and value_10 = Ast.Integer (_position, "10") in + _test_instruction content + [ + Declaration (_position, apples, Eq', value_5); + Declaration (_position, pears, Eq', value_10); + ] + +let test_equality () = + let content = "apples = 5 = pears" in + let index = None in + let apples = { Ast.pos = _position; name = "APPLES"; index } + and pears = { Ast.pos = _position; name = "PEARS"; index } + and value_5 = Ast.Integer (_position, "5") in + _test_instruction content + [ + Declaration + (_position, apples, Eq', BinaryOp (_position, Eq, value_5, Ident pears)); + ] + +let test_plus () = + let content = {| +apples = 5 + pears +|} in + let index = None in + let apples = { Ast.pos = _position; name = "APPLES"; index } + and pears = { Ast.pos = _position; name = "PEARS"; index } + and value_5 = Ast.Integer (_position, "5") in + _test_instruction content + [ + Declaration + ( _position, + apples, + Eq', + BinaryOp (_position, Plus, value_5, Ident pears) ); + ] + +let test_plus_litt () = + let content = {| +'five'+ pears +|} in + let index = None in + let pears = { Ast.pos = _position; name = "PEARS"; index } in + _test_instruction content + [ + Ast.( + Expression + (BinaryOp (_position, Plus, Literal (_position, "five"), Ident pears))); + ] + +let test_concat () = + let content = {| +$firstName + ' ' + $lastName +|} in + _test_instruction content + [ + Tree.Ast.Expression + (Tree.Ast.BinaryOp + ( _position, + Plus, + Tree.Ast.BinaryOp + ( _position, + Plus, + Tree.Ast.Ident + { + Tree.Ast.pos = _position; + name = "$FIRSTNAME"; + index = None; + }, + Tree.Ast.Literal (_position, " ") ), + Tree.Ast.Ident + { Tree.Ast.pos = _position; name = "$LASTNAME"; index = None } )); + ] + +let test_comment () = _test_instruction "! Comment" [ Comment _position ] + +let test_comment2 () = + let index = None in + let a = { Ast.pos = _position; name = "A"; index } + and value_0 = Ast.Integer (_position, "0") in + _test_instruction "a = 0 &! Comment" + Ast.[ Declaration (_position, a, Eq', value_0); Comment _position ] + +let test_comment3 () = _test_instruction {|!!1234 + |} [ Comment _position ] + +(** The exclamation mark here is an operation and not a comment *) +let test_comment4 () = + let index = None in + let a = { Ast.pos = _position; name = "A"; index } + and value_0 = Ast.Integer (_position, "0") in + _test_instruction "a = rand(0, 1) ! 0" + [ + Ast.( + Declaration + ( _position, + a, + Eq', + BinaryOp + ( _position, + Neq, + Function + ( _position, + Rand, + [ Integer (_position, "0"); Integer (_position, "1") ] ), + value_0 ) )); + ] + +let test_comment5 () = + _test_instruction "a = rand() &! Comment" + [ + Ast.Declaration + ( _position, + { Ast.pos = _position; name = "A"; index = None }, + Qsp_syntax.T.Eq', + Ast.Function (_position, Rand, []) ); + Ast.Comment _position; + ] + +let test_comment6 () = + _test_instruction + "gs 'stat' &!! It should be here, because some of the strigs have to be \ + initialized" + [ + Ast.Call (_position, "GOSUB", [ Ast.Literal (_position, "stat") ]); + Ast.Comment _position; + ] + +let test_long_comment () = + _test_instruction + {| !'this part of the comment is inside +single quotes' but "this is still part +of the same comment because sometimes +life is unfair." Oh yeah, {curly brackets +also count}. This is still the same comment. |} + [ Comment _position ] + +(** This test ensure that the unary operator is applied to the whole expression + *) +let test_precedence () = + let index = None in + let x = Ast.Ident { Ast.pos = _position; name = "X"; index } + and y = Ast.Ident { Ast.pos = _position; name = "Y"; index } in + _test_instruction "no x = y" + Ast.[ Expression (Op (_position, No, BinaryOp (_position, Eq, x, y))) ] + +(** This test ensure that a ! is not considered as a comment in an + expression *) +let test_precedence2 () = + let index = None in + let x = { Ast.pos = _position; name = "X"; index } + and y = Ast.Ident { Ast.pos = _position; name = "Y"; index } in + _test_instruction "x = y ! 0" + Ast. + [ + Declaration + ( _position, + x, + Eq', + BinaryOp (_position, Neq, y, Integer (_position, "0")) ); + ] + +let test_if () = + let index = Some Ast.(Integer (_position, "0")) in + let args = Ast.(Ident { pos = _position; name = "$ARGS"; index }) + and expr1 = Ast.(Literal (_position, "blockA")) + and expr2 = Ast.(Expression (Literal (_position, "You are in block A"))) in + _test_instruction {| if $ARGS[0] = 'blockA': + 'You are in block A' +end |} + Ast. + [ + If + { + loc = _position; + then_ = (_position, BinaryOp (_position, Eq, args, expr1), [ expr2 ]); + elifs = []; + else_ = []; + }; + ] + +let test_if2 () = + let index = Some Ast.(Integer (_position, "0")) in + let args = Ast.(Ident { pos = _position; name = "$ARGS"; index }) + and expr1 = Ast.(Literal (_position, "blockA")) + and expr2 = Ast.(Expression (Literal (_position, "You are in block A"))) in + _test_instruction {| if $ARGS[0] = 'blockA': + 'You are in block A' +end if|} + Ast. + [ + If + { + loc = _position; + then_ = (_position, BinaryOp (_position, Eq, args, expr1), [ expr2 ]); + elifs = []; + else_ = []; + }; + ] + +let test_if_chained () = + let value_0 = Ast.Integer (_position, "0") in + _test_instruction {| if 0: + 0 +end &! -- |} + Ast. + [ + If + { + loc = _position; + then_ = (_position, value_0, [ Expression value_0 ]); + elifs = []; + else_ = []; + }; + Comment _position; + ] + +let test_if_equality () = + _test_instruction {| +if 0 = 0: +end &! -- +|} + [ + Ast.If + { + loc = _position; + then_ = + ( _position, + Ast.BinaryOp + ( _position, + Qsp_syntax.T.Eq, + Ast.Integer (_position, "0"), + Ast.Integer (_position, "0") ), + [] ); + elifs = []; + else_ = []; + }; + Ast.Comment _position; + ] + +let test_if_inline () = + let value_0 = Ast.Integer (_position, "0") in + _test_instruction "if 0: 0 else 0" + Ast. + [ + If + { + loc = _position; + then_ = (_position, value_0, [ Expression value_0 ]); + elifs = []; + else_ = [ Expression value_0 ]; + }; + ] + +let test_if_inline_comment () = + let value_0 = Ast.Integer (_position, "0") in + _test_instruction "if 0: 0 else 0 &! comment " + Ast. + [ + If + { + loc = _position; + then_ = (_position, value_0, [ Expression value_0 ]); + elifs = []; + else_ = [ Expression value_0 ]; + }; + Comment _position; + ] + +let test_if_inline_comment2 () = + _test_instruction "if 0: 1 & !! Comment" + [ + Ast.If + { + loc = _position; + then_ = + ( _position, + Ast.Integer (_position, "0"), + [ + Ast.Expression (Ast.Integer (_position, "1")); + Ast.Comment _position; + ] ); + elifs = []; + else_ = []; + }; + ] + +let test_if_inline_act () = + _test_instruction "if 1 and hour >= 8: minut += 1 & act 'go': gt 'go'" + [ + Ast.If + { + loc = _position; + then_ = + ( _position, + Ast.BinaryOp + ( _position, + Qsp_syntax.T.And, + Ast.Integer (_position, "1"), + Ast.BinaryOp + ( _position, + Qsp_syntax.T.Gte, + Ast.Ident + { Ast.pos = _position; name = "HOUR"; index = None }, + Ast.Integer (_position, "8") ) ), + [ + Ast.Declaration + ( _position, + { Ast.pos = _position; name = "MINUT"; index = None }, + Qsp_syntax.T.Inc, + Ast.Integer (_position, "1") ); + Ast.Act + { + loc = _position; + label = Ast.Literal (_position, "go"); + statements = + [ + Ast.Call + (_position, "GOTO", [ Ast.Literal (_position, "go") ]); + ]; + }; + ] ); + elifs = []; + else_ = []; + }; + ] + +let test_if_inline_act2 () = + _test_instruction "if 1: act 'go': gt 'go' &! comment " + [ + Ast.If + { + loc = _position; + then_ = + ( _position, + Ast.Integer (_position, "1"), + [ + Ast.Act + { + loc = _position; + label = Ast.Literal (_position, "go"); + statements = + [ + Ast.Call + (_position, "GOTO", [ Ast.Literal (_position, "go") ]); + Ast.Comment _position; + ]; + }; + ] ); + elifs = []; + else_ = []; + }; + ] + +let test_precedence3 () = + let index = Some Ast.(Integer (_position, "0")) in + let args = Ast.(Ident { pos = _position; name = "$ARGS"; index }) + and expr1 = Ast.(Literal (_position, "blockA")) + and expr2 = Ast.(Expression (Literal (_position, "You are in block A"))) + and expr3 = Ast.(Expression (Integer (_position, "0"))) in + _test_instruction {| if $ARGS[0] = 'blockA': 'You are in block A' & 0|} + Ast. + [ + If + { + loc = _position; + then_ = + ( _position, + BinaryOp (_position, Eq, args, expr1), + [ expr2; expr3 ] ); + elifs = []; + else_ = []; + }; + ] + +let test_gs () = + _test_instruction "gs '123'" + [ Ast.(Call (_position, "GOSUB", [ Literal (_position, "123") ])) ] + +let test_gt () = + _test_instruction "gt $curloc" + [ + Ast.Call + ( _position, + "GOTO", + [ Ast.Ident { Ast.pos = _position; name = "$CURLOC"; index = None } ] + ); + ] + +let test_nl () = + _test_instruction "*NL 'It'" + [ Ast.Call (_position, "*NL", [ Ast.Literal (_position, "It") ]) ] + +let test_function () = + _test_instruction "iif(123, 1, 0)" + [ + Ast.( + Expression + (Function + ( _position, + Iif, + [ + Integer (_position, "123"); + Integer (_position, "1"); + Integer (_position, "0"); + ] ))); + ] + +(** Include a space before the parameters *) +let test_function2 () = + _test_instruction "rand (0, 1)" + [ + Ast.( + Expression + (Function + ( _position, + Rand, + [ Integer (_position, "0"); Integer (_position, "1") ] ))); + ] + +let test_precedence4 () = + _test_instruction "trim()" Ast.[ Expression (Function (_position, Trim, [])) ] + +(** This should not be a keyword without arguments, followed by an expression *) +let test_precedence5 () = + _test_instruction "clear()" Ast.[ Call (_position, "CLEAR", []) ] + +let test_precedence6 () = + _test_instruction "(1 = 0 and 2 ! 3)" + [ + Ast.Expression + (Ast.BinaryOp + ( _position, + And, + Ast.BinaryOp + ( _position, + Eq, + Ast.Integer (_position, "1"), + Ast.Integer (_position, "0") ), + Ast.BinaryOp + ( _position, + Neq, + Ast.Integer (_position, "2"), + Ast.Integer (_position, "3") ) )); + ] + +(** An identifier cannot start by a number *0 is a product and not an + identifier *) +let test_operator () = + let index = None in + let a = { Ast.pos = _position; name = "A"; index } + and value_0 = Ast.Integer (_position, "0") in + _test_instruction "a *0" + Ast.[ Expression (BinaryOp (_position, Product, Ident a, value_0)) ] + +let test_operator2 () = + let value_0 = Ast.Integer (_position, "0") in + _test_instruction "0 *rand()" + Ast. + [ + Expression + (BinaryOp (_position, Product, value_0, Function (_position, Rand, []))); + ] + +let test_dyneval () = + _test_instruction "dyneval ''" + [ + Ast.Expression + (Ast.Function (_position, Dyneval, [ Ast.Literal (_position, "") ])); + ] + +(** The parens after input are considered as arguments for the function, not a + following expression. + + This expression is a boolean. +*) +let test_input () = + _test_instruction "( input('') = '' )" + [ + Tree.Ast.Expression + (Tree.Ast.BinaryOp + ( _position, + Eq, + Tree.Ast.Function + (_position, Input, [ Tree.Ast.Literal (_position, "") ]), + Tree.Ast.Literal (_position, "") )); + ] + +let test_mutiple_inline_ifs () = + _test_instruction "if 1 > 0: 1 else if 1 < 0: 0" + [ + Tree.Ast.If + { + loc = _position; + then_ = + ( _position, + Tree.Ast.BinaryOp + ( _position, + Gt, + Tree.Ast.Integer (_position, "1"), + Tree.Ast.Integer (_position, "0") ), + [ Tree.Ast.Expression (Tree.Ast.Integer (_position, "1")) ] ); + elifs = []; + else_ = + [ + Tree.Ast.If + { + loc = _position; + then_ = + ( _position, + Tree.Ast.BinaryOp + ( _position, + Lt, + Tree.Ast.Integer (_position, "1"), + Tree.Ast.Integer (_position, "0") ), + [ + Tree.Ast.Expression (Tree.Ast.Integer (_position, "0")); + ] ); + elifs = []; + else_ = []; + }; + ]; + }; + ] + +let test_precedence7 () = + _test_instruction "(1 + 1 = '')" + [ + Tree.Ast.Expression + (Tree.Ast.BinaryOp + ( _position, + Eq, + Tree.Ast.BinaryOp + ( _position, + Plus, + Tree.Ast.Integer (_position, "1"), + Tree.Ast.Integer (_position, "1") ), + Tree.Ast.Literal (_position, "") )); + ] + +let test_precedence8 () = + _test_instruction "(0 = 1 or 0 = 1)" + [ + Tree.Ast.Expression + (Tree.Ast.BinaryOp + ( _position, + Or, + Tree.Ast.BinaryOp + ( _position, + Eq, + Tree.Ast.Integer (_position, "0"), + Tree.Ast.Integer (_position, "1") ), + Tree.Ast.BinaryOp + ( _position, + Eq, + Tree.Ast.Integer (_position, "0"), + Tree.Ast.Integer (_position, "1") ) )); + ] + +let test = + ( "Syntax", + [ + Alcotest.test_case "Location" `Quick test_empty_location; + Alcotest.test_case "Location" `Quick test_location_without_database; + Alcotest.test_case " Numeric expression" `Quick test_numeric_expression; + Alcotest.test_case "-Numeric expression" `Quick + test_negative_numeric_expression; + Alcotest.test_case "-Numeric expression2" `Quick + test_negative_numeric_expression2; + Alcotest.test_case "$Variable expression" `Quick test_str_variable; + Alcotest.test_case " Variable expression" `Quick test_variable; + Alcotest.test_case "Indexed Variable expression" `Quick + test_indexed_variable; + Alcotest.test_case "Let instruction" `Quick test_let_literal; + Alcotest.test_case "Set array_append" `Quick test_set_array_append; + Alcotest.test_case "Variable_assignation" `Quick test_direct_assignation; + Alcotest.test_case "Command assignation" `Quick test_command_assignation; + Alcotest.test_case "Variable_assignation2" `Quick test_assignation2; + Alcotest.test_case "Literal" `Quick test_literal; + Alcotest.test_case "Literal2" `Quick test_qutoted_literal; + Alcotest.test_case "Literal3" `Quick test_multilie_literal; + Alcotest.test_case "Concat Literal" `Quick test_concat_literal; + Alcotest.test_case "Nested Literal" `Quick test_nested_literal; + Alcotest.test_case "Multiline1" `Quick test_multiline1; + Alcotest.test_case "Multiline2" `Quick test_multiline2; + Alcotest.test_case "Equality" `Quick test_equality; + Alcotest.test_case "Plus" `Quick test_plus; + Alcotest.test_case "Plus_litt" `Quick test_plus_litt; + Alcotest.test_case "PlusChained" `Quick test_concat; + Alcotest.test_case "Comment" `Quick test_comment; + Alcotest.test_case "Comment2" `Quick test_comment2; + Alcotest.test_case "Comment3" `Quick test_comment3; + Alcotest.test_case "Comment4" `Quick test_comment4; + Alcotest.test_case "Comment5" `Quick test_comment5; + Alcotest.test_case "Comment6" `Quick test_comment6; + Alcotest.test_case "Multiline Comment" `Quick test_long_comment; + Alcotest.test_case "If" `Quick test_if; + Alcotest.test_case "If - end if" `Quick test_if2; + Alcotest.test_case "If_chained" `Quick test_if_chained; + Alcotest.test_case "If_equality" `Quick test_if_equality; + Alcotest.test_case "If inline" `Quick test_if_inline; + Alcotest.test_case "If inline &!" `Quick test_if_inline_comment; + Alcotest.test_case "If inline & !!" `Quick test_if_inline_comment2; + Alcotest.test_case "If : act" `Quick test_if_inline_act; + Alcotest.test_case "If : act: &!" `Quick test_if_inline_act2; + Alcotest.test_case "Precedence1" `Quick test_precedence; + Alcotest.test_case "Precedence2" `Quick test_precedence2; + Alcotest.test_case "Precedence3" `Quick test_precedence3; + Alcotest.test_case "Call gs" `Quick test_gs; + Alcotest.test_case "Call gt" `Quick test_gt; + Alcotest.test_case "Call nl" `Quick test_nl; + Alcotest.test_case "Function iif" `Quick test_function; + Alcotest.test_case "Function rand" `Quick test_function2; + Alcotest.test_case "Precedence4" `Quick test_precedence4; + Alcotest.test_case "Precedence5" `Quick test_precedence5; + Alcotest.test_case "Precedence6" `Quick test_precedence6; + Alcotest.test_case "Operator" `Quick test_operator; + Alcotest.test_case "Operator2" `Quick test_operator2; + Alcotest.test_case "Dyneval" `Quick test_dyneval; + Alcotest.test_case "Input" `Quick test_input; + Alcotest.test_case "inline if else if" `Quick test_mutiple_inline_ifs; + Alcotest.test_case "Precedence7" `Quick test_precedence7; + Alcotest.test_case "Precedence8" `Quick test_precedence8; + ] ) diff --git a/test/syntax_error.ml b/test/syntax_error.ml new file mode 100644 index 0000000..b907bc7 --- /dev/null +++ b/test/syntax_error.ml @@ -0,0 +1,85 @@ +module Parser = Qparser.Parser.Make (Qsp_syntax.Tree) +module Ast = Qsp_syntax.Tree.Ast + +let _position = (Lexing.dummy_pos, Lexing.dummy_pos) + +type 'a report = { level : Qsp_syntax.Report.level; loc : 'a; message : string } +[@@deriving eq, show] + +let report : Ast.pos report Alcotest.testable = + let equal = equal_report (fun _ _ -> true) in + let pp = pp_report (fun formater _ -> Format.fprintf formater "_position") in + Alcotest.testable pp equal + +let get_report : + (Ast.pos Syntax.location, Qsp_syntax.Report.t) result -> Ast.pos report = + function + | Ok _ -> failwith "No error" + | Error { level; loc; message } -> { level; loc; message } + +let _test_instruction : string -> Ast.pos report -> unit = + fun literal expected -> + let _location = Printf.sprintf {|# Location +%s +------- |} literal in + let actual = get_report @@ Syntax.parse _location and msg = literal in + + Alcotest.(check' report ~msg ~expected ~actual) + +let else_column () = + _test_instruction + {|IF 1: + 0 + ELSE: + 1 + END|} + { + level = Error; + loc = _position; + message = "Unexpected operator after `ELSE`"; + } + +let elseif_no_column () = + _test_instruction + {|IF 1: + 0 + ELSEIF 0 + 1 + END|} + { + level = Error; + loc = _position; + message = + "The `ELIF` expression does not end properly. A `:` is expected before \ + any instruction."; + } + +let unclosed_paren () = + _test_instruction + {|(1 + |} + { + level = Error; + loc = _position; + message = "Unexpected '('. Did you forgot a function before ?"; + } + +let act_no_column () = + _test_instruction + {|ACT 1 + 0 + END|} + { + level = Error; + loc = _position; + message = "Invalid `ACT` label. You probably missed a ':'"; + } + +let test = + ( "Syntax Errors", + [ + Alcotest.test_case "else:" `Quick else_column; + Alcotest.test_case "elseif" `Quick elseif_no_column; + Alcotest.test_case "(1" `Quick unclosed_paren; + Alcotest.test_case "act 1" `Quick act_no_column; + ] ) |