Parser_test.hs

module Language.VintageBasic.Parser_test where

import Test.HUnit
import Text.ParserCombinators.Parsec(parse)
import Text.ParserCombinators.Parsec.Pos
import Language.VintageBasic.Asserts
import Language.VintageBasic.Builtins
import Language.VintageBasic.LexCommon(Tagged(..))
import Language.VintageBasic.Parser
import Language.VintageBasic.Result
import Language.VintageBasic.Syntax
import Language.VintageBasic.Tokenizer(taggedTokensP)

tokenize source = let (Right taggedToks) = parse taggedTokensP "" source in taggedToks

goodStatements source expectedColAndStatements = TestCase $
  assertParseResult withCol SyntaxError statementListP (tokenize source) expectedColAndStatements

badStatements parser source expectedError = TestCase $
  assertParseError withCol SyntaxError statementListP (tokenize source) expectedError

goodExpr source expectedExpr = TestCase $
  assertParseResult id SyntaxError exprP (tokenize source) expectedExpr

badExpr source expectedError = TestCase $
  assertParseError id SyntaxError exprP (tokenize source) expectedError

test_parses_multiple_statements = goodStatements
    ":?::?: "
    [(2,PrintS []), (5,PrintS [])]
 
test_parse_bare_print = goodStatements
    "PRINT"
    [(1,PrintS [])]
 
test_parse_print_string = goodStatements
    "PRINT\"hello\""
    [(1,PrintS [LitX (StringLit "hello")])]
 
test_parse_print_string_ending_in_semicolon = goodStatements
    "PRINT\"hello\";"
    [(1,PrintS [LitX (StringLit "hello"), EmptySeparatorX])]
 
test_parse_print_string_ending_in_comma = goodStatements
    "PRINT\"hello\","
    [(1,PrintS [LitX (StringLit "hello"), NextZoneX])]
 
test_parse_print_with_semicolon_separated_parts = goodStatements
    "PRINT\"hello\";\"there\""
    [(1,PrintS [LitX (StringLit "hello"), EmptySeparatorX, LitX (StringLit "there")])]
 
test_parse_print_with_juxtaposed_parts = goodStatements
    "PRINT\"hello\"\"there\""
    [(1,PrintS [LitX (StringLit "hello"), LitX (StringLit "there")])]

test_parse_print_with_comma_separated_parts = goodStatements
    "PRINT\"hello\",\"there\""
    [(1,PrintS [LitX (StringLit "hello"), NextZoneX, LitX (StringLit "there")])]
 
test_parse_print_with_a_comma_at_the_start = goodStatements
    "PRINT,\"hello\""
    [(1,PrintS [NextZoneX, LitX (StringLit "hello")])]

test_parse_let = goodStatements
    "LETA=1"
    [(1,LetS (ScalarVar (VarName FloatType "A")) (LitX (FloatLit 1.0)))]
 
test_parse_let_wo_keyword = goodStatements
    "A=1"
    [(1,LetS (ScalarVar (VarName FloatType "A")) (LitX (FloatLit 1.0)))]

test_parse_multiple_dims = goodStatements
    "DIMA$(5),G(14,20)"
    [(1,DimS [(VarName StringType "A", [(LitX (FloatLit 5))]), (VarName FloatType "G", [(LitX (FloatLit 14)), (LitX (FloatLit 20))])])]

test_parse_goto = goodStatements
    "GOTO20"
    [(1,GotoS 20)]

test_ignores_space_after_target = goodStatements
    "GOTO20 "
    [(1,GotoS 20)]
 
test_parse_gosub = goodStatements
    "GOSUB20"
    [(1,GosubS 20)]

test_parse_on_goto = goodStatements
    "ON3GOTO10,20,40"
    [(1,OnGotoS (LitX (FloatLit 3)) [10,20,40])]

test_parse_on_gosub = goodStatements
    "ON3GOSUB10,20,40"
    [(1,OnGosubS (LitX (FloatLit 3)) [10,20,40])]

test_parse_data = goodStatements
    "DATA4,5,\"THIS,WORKS\""
    [(1,DataS "4,5,\"THIS,WORKS\"")]

test_parse_read = goodStatements
    "READA$(5),B"
    [(1,ReadS [ArrVar (VarName StringType "A") [(LitX (FloatLit 5))], ScalarVar (VarName FloatType "B")])]

test_parse_restore = goodStatements
    "RESTORE"
    [(1,RestoreS Nothing)]

test_parse_restore_with_line_number = goodStatements
    "RESTORE20"
    [(1,RestoreS (Just 20))]

test_parse_def_fn = goodStatements
    "DEFFNAN1$(B,CD$)=4+B"
    [(1,DefFnS (VarName StringType "AN1") [(VarName FloatType "B"), (VarName StringType "CD")] (BinX AddOp (LitX (FloatLit 4)) (VarX (ScalarVar (VarName FloatType "B")))))]

test_parse_fn = goodStatements
    "?FNAN2$(1,\"X\")"
    [(1,PrintS [FnX (VarName StringType "AN2") [(LitX (FloatLit 1)), (LitX (StringLit "X"))]])]

test_parse_end = goodStatements
    "END"
    [(1,EndS)]

test_parse_stop = goodStatements
    "STOP"
    [(1,StopS)]

fl v = LitX (FloatLit v)
sl s = LitX (StringLit s)
fv s = VarX (ScalarVar (VarName FloatType s))
iv s = VarX (ScalarVar (VarName IntType s))
sv s = VarX (ScalarVar (VarName StringType s))

test_primitive_expressions = TestList [
    "round number"  ~: goodExpr "234" (fl 234),
    "float"         ~: goodExpr "2.3" (fl 2.3),
    "string"        ~: goodExpr "\"Work\"" (sl "Work"),
    "builtin"       ~: goodExpr "SIN(1)" (BuiltinX SinBI [(fl 1)]),
    "builtin2"      ~: goodExpr "LEFT$(A$,1)" (BuiltinX LeftBI [sv "A", fl 1]),
    "fn"            ~: goodExpr "FNAB(1,2,3)" (FnX (VarName FloatType "AB") [fl 1, fl 2, fl 3]),
    "float var"     ~: goodExpr "BR" (fv "BR"),
    "int var"       ~: goodExpr "BR%" (iv "BR"),
    "string var"    ~: goodExpr "BR$" (sv "BR"),
    "array var"     ~: goodExpr "AB(20, 5)" (VarX (ArrVar (VarName FloatType "AB") [fl 20, fl 5]))
  ]

test_operators = TestList [
    "unary +"       ~: goodExpr "+A"   (fv "A"),
    "unary -"       ~: goodExpr "-A"   (MinusX (fv "A")),
    "num add"       ~: goodExpr "1+2"  (BinX AddOp (fl 1) (fl 2)),
    "num sub"       ~: goodExpr "1-2"  (BinX SubOp (fl 1) (fl 2)),
    "num mul"       ~: goodExpr "1*2"  (BinX MulOp (fl 1) (fl 2)),
    "num div"       ~: goodExpr "1/2"  (BinX DivOp (fl 1) (fl 2)),
    "num pow"       ~: goodExpr "1^2"  (BinX PowOp (fl 1) (fl 2)),
    "num eq"        ~: goodExpr "1=2"  (BinX EqOp  (fl 1) (fl 2)),
    "num ne"        ~: goodExpr "1<>2" (BinX NEOp  (fl 1) (fl 2)),
    "num lt"        ~: goodExpr "1<2"  (BinX LTOp  (fl 1) (fl 2)),
    "num gt"        ~: goodExpr "1>2"  (BinX GTOp  (fl 1) (fl 2)),
    "string concat" ~: goodExpr "\"A\"+\"B\"" (BinX AddOp (sl "A") (sl "B")),
    "string lt"     ~: goodExpr "\"A\"<\"B\"" (BinX LTOp  (sl "A") (sl "B")),
    "string gt"     ~: goodExpr "\"A\">\"B\"" (BinX GTOp  (sl "A") (sl "B")),
    "string eq"     ~: goodExpr "\"A\"=\"B\"" (BinX EqOp  (sl "A") (sl "B")),
    "and"           ~: goodExpr "1=2AND3=4" (BinX AndOp (BinX EqOp (fl 1) (fl 2)) (BinX EqOp (fl 3) (fl 4))),
    "or"            ~: goodExpr "1=2OR3=4"  (BinX OrOp (BinX EqOp (fl 1) (fl 2)) (BinX EqOp (fl 3) (fl 4))),
    "not"           ~: goodExpr "NOT1" (NotX (fl 1))
  ]

test_associativity = TestList [
    "or assoc"      ~: goodExpr "1OR2OR3" (BinX OrOp (BinX OrOp (fl 1) (fl 2)) (fl 3)),
    "and assoc"     ~: goodExpr "1AND2AND3" (BinX AndOp (BinX AndOp (fl 1) (fl 2)) (fl 3)),
    "eq assoc"      ~: goodExpr "1=2=3" (BinX EqOp (BinX EqOp (fl 1) (fl 2)) (fl 3)),
    "ne assoc"      ~: goodExpr "1<>2<>3" (BinX NEOp (BinX NEOp (fl 1) (fl 2)) (fl 3)),
    "lt assoc"      ~: goodExpr "1<2<3" (BinX LTOp (BinX LTOp (fl 1) (fl 2)) (fl 3)),
    "le assoc"      ~: goodExpr "1<=2<=3" (BinX LEOp (BinX LEOp (fl 1) (fl 2)) (fl 3)),
    "gt assoc"      ~: goodExpr "1>2>3" (BinX GTOp (BinX GTOp (fl 1) (fl 2)) (fl 3)),
    "ge assoc"      ~: goodExpr "1>=2>=3" (BinX GEOp (BinX GEOp (fl 1) (fl 2)) (fl 3)),
    "add assoc"     ~: goodExpr "1+2+3" (BinX AddOp (BinX AddOp (fl 1) (fl 2)) (fl 3)),
    "sub assoc"     ~: goodExpr "1-2-3" (BinX SubOp (BinX SubOp (fl 1) (fl 2)) (fl 3)),
    "mul assoc"     ~: goodExpr "1*2*3" (BinX MulOp (BinX MulOp (fl 1) (fl 2)) (fl 3)),
    "div assoc"     ~: goodExpr "1/2/3" (BinX DivOp (BinX DivOp (fl 1) (fl 2)) (fl 3)),
    "pow assoc"     ~: goodExpr "1^2^3" (BinX PowOp (fl 1) (BinX PowOp (fl 2) (fl 3)))
  ]

test_precedence = TestList [
    "and beats or"      ~: goodExpr "1OR2AND3" (BinX OrOp (fl 1) (BinX AndOp (fl 2) (fl 3))),
    "not beats and"     ~: goodExpr "NOT1AND2" (BinX AndOp (NotX (fl 1)) (fl 2)),
    "eq beats not"      ~: goodExpr "NOT1=2"   (NotX (BinX EqOp (fl 1) (fl 2))),
    "eq class"          ~: goodExpr "1=2<>3<4<=5>6>=7" (BinX GEOp (BinX GTOp (BinX LEOp (BinX LTOp (BinX NEOp (BinX EqOp (fl 1) (fl 2)) (fl 3)) (fl 4)) (fl 5)) (fl 6)) (fl 7)),
    "eq class rev"      ~: goodExpr "1>=2>3<=4<5<>6=7" (BinX EqOp (BinX NEOp (BinX LTOp (BinX LEOp (BinX GTOp (BinX GEOp (fl 1) (fl 2)) (fl 3)) (fl 4)) (fl 5)) (fl 6)) (fl 7)),
    "add beats eq"      ~: goodExpr "1=2+3" (BinX EqOp (fl 1) (BinX AddOp (fl 2) (fl 3))),
    "add class"         ~: goodExpr "1+2-3" (BinX SubOp (BinX AddOp (fl 1) (fl 2)) (fl 3)),
    "add class rev"     ~: goodExpr "1-2+3" (BinX AddOp (BinX SubOp (fl 1) (fl 2)) (fl 3)),
    "mul beats add"     ~: goodExpr "1+2*3" (BinX AddOp (fl 1) (BinX MulOp (fl 2) (fl 3))),
    "mul class"         ~: goodExpr "1*2/3" (BinX DivOp (BinX MulOp (fl 1) (fl 2)) (fl 3)),
    "mul class rev"     ~: goodExpr "1/2*3" (BinX MulOp (BinX DivOp (fl 1) (fl 2)) (fl 3)),
    "pow beats mul"     ~: goodExpr "1*2^3" (BinX MulOp (fl 1) (BinX PowOp (fl 2) (fl 3))),
    "unary - beats pow" ~: goodExpr "-A^B" (BinX PowOp (MinusX (fv "A")) (fv "B"))
  ]

test_parentheses = TestList [
    goodExpr "(1+2)*3" (BinX MulOp (ParenX (BinX AddOp (fl 1) (fl 2))) (fl 3)),
    goodExpr "-(1+2)*3" (BinX MulOp (MinusX (ParenX (BinX AddOp (fl 1) (fl 2)))) (fl 3)),
    goodExpr "(1+(2-3))*4" (BinX MulOp (ParenX (BinX AddOp (fl 1) (ParenX (BinX SubOp (fl 2) (fl 3))))) (fl 4))
  ]

test_embedded_spaces_are_ignored = TestList [
    goodExpr "1 * 2  +3-  4" (BinX SubOp (BinX AddOp (BinX MulOp (fl 1) (fl 2)) (fl 3)) (fl 4)),
    goodExpr "CHR$ ( A ) " (BuiltinX ChrBI [fv "A"])
  ]

test_bad_expressions = TestList [
    "starting with operator" ~: badExpr "/4" "UNEXPECTED /",
    "ending with operator"   ~: badExpr "4/" "UNEXPECTED END OF LINE",
    "double operator"        ~: badExpr "4/*4" "UNEXPECTED *"
  ]