Failures.hs

module Hydra.Sources.Test.Inference.Failures (failureTests) where

import Hydra.Kernel
import Hydra.Testing
import qualified Hydra.Dsl.Core as Core
import Hydra.Dsl.Testing as Testing
import Hydra.Dsl.ShorthandTypes
import qualified Hydra.Dsl.Terms as Terms
import qualified Hydra.Dsl.Types as Types
import Hydra.Sources.Test.TestGraph

import           Hydra.Dsl.TTerms as TTerms
import qualified Hydra.Dsl.TTypes as T

import qualified Data.Map as M
import qualified Data.Set as S
import Prelude hiding (map, sum)


failureTests :: TTerm TestGroup
failureTests = supergroup "Expected failures" [
  undefinedVariableTests,
  unificationFailureTests,
  invalidApplicationTests,
  selfApplicationTests,
  arityMismatchTests,
  recursiveTypeTests,
  occurCheckTests,
  typeConstructorMisuseTests,
  polymorphismViolationTests,
  letBindingMismatchTests,
  constraintSolverEdgeCaseTests,
  primitiveTypeErrorTests,
  complexConstraintFailureTests]

undefinedVariableTests :: TTerm TestGroup
undefinedVariableTests = supergroup "Undefined variable" [
  subgroup "Basic unbound variables" [
    expectFailure 1 []
      (var "x"),
    expectFailure 2 []
      (lambda "x" $ var "y"),
    expectFailure 3 []
      (lets ["x">: int32 42] $ var "y")],

  subgroup "Unbound in let expressions" [
    expectFailure 1 []
      (lets ["x">: var "y"] $ var "x"),
    expectFailure 2 []
      (lets ["x">: var "y", "z">: int32 42] $ var "x"),
    expectFailure 3 []
      (lets ["x">: int32 42, "y">: var "z"] $ pair (var "x") (var "y"))],

  subgroup "Shadowing scope errors" [
    expectFailure 1 []
      (lambda "x" $ lets ["y">: var "x"] $ var "z"),
    expectFailure 2 []
      (lets ["x">: int32 42] $ lets ["y">: var "x"] $ var "z"),
    expectFailure 3 []
      (lets ["x">: lambda "y" $ var "z"] $ var "x")]]

unificationFailureTests :: TTerm TestGroup
unificationFailureTests = supergroup "Unification failure" [
  subgroup "Basic type mismatches" [
    expectFailure 1 []
      (primitive _math_add @@ int32 42 @@ string "foo"),
    expectFailure 2 []
      (list [int32 42, string "foo"]),
    expectFailure 3 []
      (list [list [int32 42], string "foo"]),
    expectFailure 4 []
      (pair (int32 42) (string "foo") @@ string "bar")],

  subgroup "Collection type mismatches" [
    expectFailure 1 []
      (primitive _lists_cons @@ int32 42 @@ string "not a list"),
    expectFailure 2 []
      (list [int32 42, list [string "foo"]]),
    expectFailure 3 []
      (pair (list [int32 42]) (list [string "foo"]) @@ int32 137),
    expectFailure 4 []
      (primitive _lists_concat @@ list [list [int32 42], list [string "foo"]])],

  subgroup "Conditional type mismatches" [
    expectFailure 1 []
      (primitive _logic_ifElse @@ true @@ int32 42 @@ string "foo"),
    expectFailure 2 []
      (primitive _logic_ifElse @@ true @@ list [int32 42] @@ string "foo"),
    expectFailure 3 []
      (primitive _logic_ifElse @@ true @@ (lambda "x" $ var "x") @@ int32 42)],

  subgroup "Polymorphic instantiation conflicts" [
    expectFailure 1 []
      (lets ["f">: lambda "x" $ var "x"] $
        list [var "f" @@ int32 42, var "f" @@ string "foo"]),
    expectFailure 2 []
      (lets ["id">: lambda "x" $ var "x"] $
        pair (var "id" @@ int32 42) (var "id" @@ string "foo") @@ true),
    expectFailure 3 []
      (lets ["cons">: primitive _lists_cons] $
        list [var "cons" @@ int32 42, var "cons" @@ string "foo"])]]

invalidApplicationTests :: TTerm TestGroup
invalidApplicationTests = supergroup "Invalid application" [
  subgroup "Non-function application" [
    expectFailure 1 []
      (int32 42 @@ int32 137),
    expectFailure 2 []
      (string "foo" @@ int32 42),
    expectFailure 3 []
      (true @@ false),
    expectFailure 4 []
      (float64 3.14 @@ int32 42)],

  subgroup "Collection application" [
    expectFailure 1 []
      (list [int32 42] @@ string "bar"),
    expectFailure 2 []
      (pair (int32 42) (string "foo") @@ true),
    expectFailure 3 []
      (list [] @@ int32 42),
    expectFailure 4 []
      (tuple [int32 1, int32 2, int32 3] @@ string "index")],

  subgroup "Primitive misapplication" [
    expectFailure 1 []
      (primitive _maps_empty @@ string "foo"),
    expectFailure 2 []
      (primitive _sets_empty @@ int32 42),
    expectFailure 3 []
      (optional nothing @@ string "value"),
    expectFailure 4 []
      (list [] @@ true)]]

selfApplicationTests :: TTerm TestGroup
selfApplicationTests = supergroup "Self-application" [
  subgroup "Direct self-application" [
    expectFailure 1 []
      (lambda "x" $ var "x" @@ var "x"),
    expectFailure 2 []
      (lets ["f">: var "f" @@ var "f"] $ var "f")],

  subgroup "Indirect self-application" [
    expectFailure 1 []
      (lets ["f">: lambda "x" $ var "g" @@ var "f", "g">: lambda "y" $ var "y" @@ var "y"] $ var "f"),
    expectFailure 2 []
      (lets ["a">: var "b" @@ var "a", "b">: lambda "x" $ var "x" @@ var "x"] $ var "a"),
    expectFailure 3 []
      (lets ["cycle">: lambda "f" $ var "f" @@ var "cycle"] $ var "cycle" @@ var "cycle")]]

arityMismatchTests :: TTerm TestGroup
arityMismatchTests = supergroup "Arity mismatch" [
  subgroup "Too many arguments" [
    expectFailure 1 []
      (primitive _math_add @@ int32 42 @@ int32 137 @@ int32 999),
    expectFailure 2 []
      ((lambda "x" $ lambda "y" $ var "x") @@ int32 42 @@ string "foo" @@ true),
    expectFailure 3 []
      (primitive _lists_cons @@ int32 42 @@ list [int32 137] @@ string "extra")],

  subgroup "Wrong argument types with extra args" [
    expectFailure 1 []
      (primitive _strings_length @@ int32 42 @@ string "extra"),
    expectFailure 2 []
      (primitive _logic_not @@ int32 42 @@ true),
    expectFailure 3 []
      ((lambda "x" $ int32 42) @@ string "arg" @@ int32 137 @@ true)]]

recursiveTypeTests :: TTerm TestGroup
recursiveTypeTests = supergroup "Recursive type construction" [
  subgroup "Direct recursive types" [
    expectFailure 1 []
      (lets ["x">: list [var "x"]] $ var "x"),
    expectFailure 2 []
      (lets ["x">: pair (var "x") (int32 42)] $ var "x"),
    expectFailure 3 []
      (lets ["x">: tuple [var "x", var "x"]] $ var "x")],

  subgroup "Recursive function types" [
    expectFailure 1 []
      (lets ["f">: lambda "x" $ var "f"] $ var "f"),
    expectFailure 2 []
      (lets ["f">: lambda "x" $ lambda "y" $ var "f" @@ var "f"] $ var "f"),
    expectFailure 3 []
      (lets ["f">: lambda "x" $ list [var "f"]] $ var "f")],

  subgroup "Mutually recursive types" [
    expectFailure 1 []
      (lets ["x">: list [var "y"], "y">: pair (var "x") (int32 42)] $ var "x"),
    expectFailure 2 []
      (lets ["a">: lambda "x" $ var "b", "b">: var "a"] $ var "a"),
    expectFailure 3 []
      (lets ["f">: list [var "g"], "g">: tuple [var "f", var "f"]] $ var "f")]]

occurCheckTests :: TTerm TestGroup
occurCheckTests = supergroup "Occur check failures" [
  subgroup "Function occur checks" [
    expectFailure 1 []
      (lets ["g">: lambda "h" $ var "g" @@ var "g" @@ var "h"] $ var "g")],

  subgroup "Mutual occur checks" [
    expectFailure 1 []
      (lets [
        "f">: lambda "x" $ var "g" @@ var "f",
        "g">: lambda "y" $ var "f" @@ var "g"] $ var "f"),
    expectFailure 2 []
      (lets [
        "a">: lambda "x" $ var "b" @@ var "a" @@ var "x",
        "b">: lambda "y" $ var "a" @@ var "b"] $ var "a"),
    expectFailure 3 []
      (lets [
        "cycle1">: var "cycle2" @@ var "cycle1",
        "cycle2">: lambda "x" $ var "cycle1" @@ var "x"] $ var "cycle1")],

  subgroup "Complex occur checks" [
    expectFailure 1 []
      (lets ["omega">: lambda "x" $ var "x" @@ var "x" @@ var "omega"] $ var "omega"),
    expectFailure 2 []
      (lets ["loop">: lambda "x" $ lambda "y" $ var "loop" @@ (var "x" @@ var "loop") @@ var "y"] $ var "loop")]]

typeConstructorMisuseTests :: TTerm TestGroup
typeConstructorMisuseTests = supergroup "Type constructor misuse" [
  subgroup "List constructor errors" [
    expectFailure 1 []
      (primitive _lists_cons @@ (list [int32 42]) @@ int32 137),  -- Wrong order
    expectFailure 2 []
      (primitive _lists_length @@ int32 42),  -- Not a list
    expectFailure 3 []
      (primitive _lists_head @@ string "not a list"),
    expectFailure 4 []
      (primitive _lists_tail @@ int32 42)],

  subgroup "String constructor errors" [
    expectFailure 1 []
      (primitive _strings_length @@ list [string "foo"]),  -- Not a string
    expectFailure 2 []
      (primitive _strings_cat @@ int32 42),
    expectFailure 3 []
      (primitive _strings_fromList @@ string "not a list"),
    expectFailure 4 []
      (primitive _strings_toList @@ int32 42)],

  subgroup "Math constructor errors" [
    expectFailure 1 []
      (primitive _math_add @@ list [int32 42] @@ int32 137),  -- Wrong type for math
    expectFailure 2 []
      (primitive _math_sub @@ string "not a number" @@ int32 42),
    expectFailure 3 []
      (primitive _math_mul @@ int32 42 @@ string "not a number"),
    expectFailure 4 []
      (primitive _math_div @@ true @@ false)]]

polymorphismViolationTests :: TTerm TestGroup
polymorphismViolationTests = supergroup "Polymorphism violations" [
  subgroup "Identity function violations" [
    expectFailure 1 []
      (lets ["id">: lambda "x" $ var "x"] $
        primitive _math_add @@ (var "id" @@ int32 42) @@ (var "id" @@ string "foo")),
    expectFailure 2 []
      (lets ["id">: lambda "x" $ var "x"] $
        list [var "id" @@ int32 42, var "id" @@ string "foo"]),
    expectFailure 3 []
      (lets ["id">: lambda "x" $ var "x"] $
        pair (var "id" @@ int32 42) (var "id" @@ string "foo") @@ true)],

  subgroup "Constrained polymorphism violations" [
    expectFailure 1 []
      (lets ["f">: lambda "x" $ list [var "x", int32 42]] $ var "f" @@ string "foo"),
    expectFailure 2 []
      (lets ["g">: lambda "x" $ pair (var "x") (string "constant")] $
        primitive _math_add @@ (first $ var "g" @@ int32 42) @@ (first $ var "g" @@ string "bad")),
    expectFailure 3 []
      (lets ["h">: lambda "x" $ primitive _lists_cons @@ var "x" @@ list [int32 0]] $
        var "h" @@ string "incompatible")],

  subgroup "Higher-order polymorphism violations" [
    expectFailure 1 []
      (lambda "f" $ pair (var "f" @@ int32 42) (var "f" @@ string "foo")),
    expectFailure 2 []
      (lambda "g" $ list [var "g" @@ int32 1, var "g" @@ string "bad"]),
    expectFailure 3 []
      (lambda "h" $ primitive _math_add @@ (var "h" @@ int32 42) @@ (var "h" @@ string "error"))]]

letBindingMismatchTests :: TTerm TestGroup
letBindingMismatchTests = supergroup "Let binding type mismatches" [
  subgroup "Application type mismatches" [
    expectFailure 1 []
      (lets [
        "x">: int32 42,
        "y">: var "x" @@ string "foo"] $ var "y"),
    expectFailure 2 []
      (lets [
        "f">: lambda "x" $ string "result",
        "g">: var "f" @@ int32 42 @@ string "extra"] $ var "g"),
    expectFailure 3 []
      (lets [
        "num">: int32 42,
        "bad">: var "num" @@ var "num"] $ var "bad")],

  subgroup "Collection type mismatches" [
    expectFailure 1 []
      (lets [
        "list1">: list [int32 42],
        "list2">: primitive _lists_cons @@ string "foo" @@ var "list1"] $ var "list2"),
    expectFailure 2 []
      (lets [
        "nums">: list [int32 1, int32 2],
        "mixed">: primitive _lists_cons @@ string "bad" @@ var "nums"] $ var "mixed"),
    expectFailure 3 []
      (lets [
        "pair1">: pair (int32 42) (string "foo"),
        "pair2">: pair (string "bar") (var "pair1")] $
        primitive _math_add @@ (first $ var "pair2") @@ int32 1)],

  subgroup "Function binding mismatches" [
    expectFailure 1 []
      (lets [
        "add">: primitive _math_add,
        "badCall">: var "add" @@ string "not a number" @@ int32 42] $
        var "badCall"),
    expectFailure 2 []
      (lets [
        "f">: lambda "x" $ lambda "y" $ var "x",
        "g">: var "f" @@ int32 42,
        "bad">: var "g" @@ string "foo" @@ true] $
        var "bad")]]

constraintSolverEdgeCaseTests :: TTerm TestGroup
constraintSolverEdgeCaseTests = supergroup "Constraint solver edge cases" [
  subgroup "Complex constraint propagation" [
    expectFailure 1 []
      (lets [
        "complex">: lambda "f" $ lambda "g" $ lambda "x" $
          var "f" @@ (var "g" @@ var "x") @@ (var "g" @@ (var "f" @@ var "x")),
        "bad">: var "complex" @@ (lambda "a" $ int32 42) @@ (lambda "b" $ string "foo")] $ var "bad")],

  subgroup "Fixed point combinators" [
    expectFailure 1 []
      (lets [
        "fix">: lambda "f" $ var "f" @@ var "f",
        "bad">: var "fix" @@ (lambda "x" $ var "x" @@ var "x")] $ var "bad"),
    expectFailure 2 []
      (lets [
        "y">: lambda "f" $ (lambda "x" $ var "f" @@ (var "x" @@ var "x")) @@
                           (lambda "x" $ var "f" @@ (var "x" @@ var "x")),
        "bad">: var "y" @@ (lambda "rec" $ lambda "n" $ var "rec" @@ var "rec")] $ var "bad"),
    expectFailure 3 []
      (lets [
        "omega">: lambda "x" $ var "x" @@ var "x",
        "bad">: var "omega" @@ var "omega"] $ var "bad")],

  subgroup "Constraint cycles" [
    expectFailure 1 []
      (lets [
        "a">: lambda "x" $ var "b" @@ var "c" @@ var "x",
        "b">: lambda "y" $ var "c" @@ var "a" @@ var "y",
        "c">: lambda "z" $ var "a" @@ var "b" @@ var "z"] $
        var "a" @@ int32 42),
    expectFailure 2 []
      (lets [
        "circular">: lambda "f" $ var "f" @@ var "circular" @@ var "f"] $
        var "circular" @@ var "circular")]]

primitiveTypeErrorTests :: TTerm TestGroup
primitiveTypeErrorTests = supergroup "Primitive function type errors" [
  subgroup "Logic primitive errors" [
    expectFailure 1 []
      (primitive _logic_ifElse @@ int32 42 @@ true @@ false),  -- Condition not boolean
    expectFailure 2 []
      (primitive _logic_ifElse @@ true @@ int32 42 @@ false),  -- Branch type mismatch
    expectFailure 3 []
      (primitive _logic_and @@ int32 42 @@ true),
    expectFailure 4 []
      (primitive _logic_or @@ true @@ string "not boolean")],

  subgroup "Collection primitive errors" [
    expectFailure 1 []
      (primitive _maps_lookup @@ int32 42 @@ string "not a map"),  -- Not a map
    expectFailure 2 []
      (primitive _sets_member @@ int32 42 @@ list [int32 42]),  -- Not a set
    expectFailure 3 []
      (primitive _lists_head @@ string "not a list"),
    expectFailure 4 []
      (primitive _optionals_fromMaybe @@ int32 42 @@ string "not optional")],

  subgroup "Math primitive errors" [
    expectFailure 1 []
      (primitive _math_add @@ string "not a number" @@ int32 42),
    expectFailure 2 []
      (primitive _math_mul @@ true @@ false),
    expectFailure 3 []
      (primitive _math_div @@ list [int32 42] @@ int32 2),
    expectFailure 4 []
      (primitive _math_mod @@ int32 42 @@ string "not a number")]]

complexConstraintFailureTests :: TTerm TestGroup
complexConstraintFailureTests = supergroup "Complex constraint failures" [
  subgroup "Multi-level constraint conflicts" [
    expectFailure 1 []
      (lets [
        "f">: lambda "x" $ lambda "y" $ pair (var "x") (var "y"),
        "g">: lambda "a" $ var "f" @@ var "a" @@ var "a",
        "h">: var "g" @@ (lambda "z" $ var "z")] $ var "h" @@ int32 42),
    expectFailure 2 []
      (lets [
        "weird">: lambda "f" $ lambda "x" $ var "f" @@ (var "f" @@ var "x"),
        "bad">: var "weird" @@ (lambda "y" $ pair (var "y") (int32 42))] $ var "bad"),
    expectFailure 3 []
      (lets [
        "nested">: lambda "f" $ lambda "g" $ lambda "x" $
          var "f" @@ (var "g" @@ (var "f" @@ (var "g" @@ var "x"))),
        "int_f">: lambda "n" $ primitive _math_add @@ var "n" @@ int32 1,
        "str_g">: lambda "s" $ primitive _strings_cat @@ list [var "s", string "!"],
        "bad">: var "nested" @@ var "int_f" @@ var "str_g"] $ var "bad")],

  subgroup "Function composition failures" [
    expectFailure 1 []
      (lets [
        "triple">: lambda "f" $ lambda "x" $ var "f" @@ (var "f" @@ (var "f" @@ var "x")),
        "increment">: lambda "n" $ primitive _math_add @@ var "n" @@ int32 1,
        "stringify">: lambda "s" $ primitive _strings_cat @@ list [var "s", string "!"],
        "bad">: var "triple" @@ var "increment" @@ var "stringify"] $ var "bad"),
    expectFailure 2 []
      (lets [
        "compose">: lambda "f" $ lambda "g" $ lambda "x" $ var "f" @@ (var "g" @@ var "x"),
        "reverse_compose">: lambda "g" $ lambda "f" $ lambda "x" $ var "f" @@ (var "g" @@ var "x"),
        "bad">: var "compose" @@ var "reverse_compose" @@ primitive _math_add @@ primitive _strings_length] $
        var "bad")]]