(** Concatenation of all labeled tuples test from the compiler testsuite *)

exception Odd

let x_must_be_even (~x, y) =
   if x mod 2 = 1 then
      raise Odd
   else
      (~x, y)

let foo xy k_good k_bad =
   match x_must_be_even xy with
   | (~x, y) -> k_good ()
   | exception Odd -> k_bad ()

(* Test correctness *)
let _ = foo (~x:2, 5) (fun () -> true) (fun () -> false)
let _ = foo (~x:3, 5) (fun () -> false) (fun () -> true)

(* Test that the actions occur outside of the exception handler *)
let _ =
   try
      foo (~x:2, 5) (fun () -> raise Odd) (fun () -> false)
   with Odd -> true
let _ =
   try
      foo (~x:3, 5) (fun () -> false) (fun () -> raise Odd)
   with Odd -> true

(* Labeled tuple pattern *)
let (~x:x0, ~y:y0, _) = ~x: 1, ~y: 2, "ignore me"

(* Pattern with punning and type annotation *)
let (~(x:int), ~y, _) = ~x: 1, ~y: 2, "ignore me"

(* Patterns in functions *)
let f = fun (~foo, ~bar:bar) -> foo * 10 + bar
let bar = 5
let _ = f (~foo:1, ~bar)

(* Correct annotation *)
let f : (foo:int * bar:int) -> int =
   fun (~foo, ~bar:bar) -> foo * 10 + bar

let f = fun (~foo, ~bar:bar) : (foo:int * bar:int) -> foo * 10 + bar

(* Missing label *)
let f : (int * bar:int) -> int = fun (~foo, ~bar:bar) -> foo * 10 + bar

let f = fun (~foo, ~bar:bar) : (foo:int * int) -> foo * 10 + bar

(* Wrong label *)
let f : (foo:int * foo':int) -> int =
   fun (~foo, ~bar:bar) -> foo * 10 + bar

(* Wrong type *)
let f : (foo:float * foo':int) -> int =
   fun (~foo, ~bar:bar) -> foo * 10 + bar

(* Annotated pattern *)
let f (~x,y : (x:int * int)) : int = x + y

(* Misannotated pattern *)
let f (~x,y : (int * int)) : int = x + y

let f (~x,y : (int * x:int)) : int = x + y

(* Annotation within pattern *)
let f (~(x:int),y : (x:int * int)) : int = x + y

let f (~(x:int),y) = x + y

let f (~x:(x0:int),y) = x0 + y

(* Misannotation within pattern *)
let f (~(x:float),y) = x + y

 (* Reordering in functions *)
type xy = (x:int * y:int)
type yx = (y:int * x:int)
let xy_id (pt : xy) = pt
let yx_id (pt : yx) = pt

let xy_id (~y, ~x) : xy = ~x, ~y
let swap (~x, ~y) = ~y, ~x
let swap (~y, ~x : xy) = ~y, ~x
let swap (~x, ~y) = (~x, ~y : yx)

let swap (pt : xy) : yx = pt

let swap : xy -> yx = Fun.id

let swap : xy -> yx = xy_id

let swap : xy -> yx = yx_id

(* Reordering and partial matches *)
let lt = ~x:1, 2, ~y:3, ~z:4, 5, 6

(* Full match, in order *)
let matches =
  let ~x, k1, ~y, ~z, k2, k3 = lt in
  x, k1, y, z, k2, k3

(* Full match, over-bound *)
let matches =
  let ~x, k1, ~y, ~z, x, k3 = lt in
  ()

let matches =
  let ~x, k1, ~y, ~z:x, k2, k3 = lt in
  ()

(* Full match, missing label *)
let matches =
  let ~x, k1, ~y, k2, k3 = lt in
  ()

(* Full match, wrong label *)
let matches =
  let ~x, k1, ~y, ~w, k2, k3 = lt in
  ()

(* Full match, extra label *)
let matches =
  let ~x, k1, ~y, ~z, ~w, k2, k3 = lt in
  ()

(* Full match, extra unlabeled label *)
let matches =
  let ~x, k1, ~y, ~z, k2, k3, k4 = lt in
  x, y, z

(* Partial match *)
let matches =
  let ~x, ~z, .. = lt in
  x, z

(* Partial match, reordered *)
let matches =
  let ~z, ~x, .. = lt in
  x, z

(* Partial match, reordered, over-bound *)
let matches =
  let ~z:x, ~x, .. = lt in
  x

(* Partial match one *)
let matches =
  let ~z, .. = lt in
  z

(* Partial match all *)
let matches =
   let ~x, k1, ~y, ~z, k2, k3, .. = lt in
   x, k1, y, z, k2, k3


(* Partial match bad name *)
let matches =
   let ~w, ~y, ~x, .. = lt in
   ()


(* Nested pattern *)
let f (z, (~y, ~x)) = x, y, z

(* Non-principally known patterns *)

let f (z, (~y, ~x, ..)) = x, y, z


let f (~x, ~y, ..) = x, y


(* Labeled tuples nested in records *)

let x = ref (~x:1, ~y:2, 3, ~z:4)

(* Good match *)
let _1234 = match x with
| { contents = ~x:x0, ~y, w, ~z:x } -> x0, y, w, x


(* Good partial match *)
let _1  = match x with
| { contents = ~y, ..} -> y


(* Wrong label *)
let () = match x with
| { contents = ~w , .. } -> w


(* Missing unlabeled element *)
let () = match x with
| { contents = ~x, ~y, ~z } -> y


(* Extra unlabeled element *)
let () = match x with
| { contents = ~x, ~y, w1, ~z, w2 } -> y

(* Extra unlabeled element, open *)
let () = match x with
| { contents = ~x, ~y, w1, ~z, w2, .. } -> y


(* Missing label *)
let () = match x with
| { contents = ~x, ~y, w } -> y


(* Extra label *)
let () = match x with
| { contents = ~z, ~y, ~w, ~x } -> y


(* Behavior w.r.t whether types are principally known *)

let f (z : (x:_ * y:_)) =
  match z with
  | ~y, ~x -> x + y


let f = function ~x, ~y -> x + y

let g z =
  (f z, match z with ~y, ~x -> x + y)


let f = function ~x, ~y -> x + y

let g z =
  match z with ~y, ~x -> x + y, f z


(* More re-ordering stress tests *)
type t =
  x1:int *
  y2:int *
  int *
  x4:int *
  x5:int *
  y6:int *
  y7:int *
  int *
  int *
  y10:int *
  x11:int

let t : t = ~x1:1, ~y2:2, 3, ~x4:4, ~x5:5, ~y6:6, ~y7:7, 8, 9, ~y10:10, ~x11:11

let _ =
  let (~y2, ~y7, ~y10, ..) = t in
  y2, y7, y10


let _ =
  let (a, b, c, ..) = t in
  (a, b, c)

let _ =
  let (n3, ~y6:n6, ~y7, ~x1:n1, ..) = t in
  (n1, n6, n3, y7)

let _ =
  let (~x4, ~x1, ~x11, ~x5, ..) = t in
  (x1, x4, x5, x11)


let _ =
  let (~y2:n2, ~y6:n6, n3, ~x1:n1, ~y7:n7, n8,
       ~y10:n10, ~x4:n4, ~x5:n5, ~x11:n11, n9) =
    t
  in
  (n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11)


let _ =
  let (n3, n8, n9, ~y2:n2, ~y6:n6, ~y7:n7,
       ~y10:n10, ~x1:n1, ~x4:n4, ~x5:n5, ~x11:n11) =
    t
  in
  (n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11)


let _ =
  let (~x1:n1, ~y2:n2, n3, ~x4:n4, ~x5:n5,
       ~y6:n6, ~y7:n7, n8, n9, ~y10:n10, ~x11:n11) =
    t
  in
  (n1, n2, n3, n4, n5, n6, n7, n8, n9, n10, n11)

(* Constructor with labeled arguments (disallowed) *)

type ('a, 'b) pair = Pair of 'a * 'b
let x = Pair (~x: 5, 2)


(* Labeled tuple pattern in constructor pattern, with the same arity as the
   constructor. This is intentionally disallowed. *)
let f = function
| Pair (~x:5, 2) -> true
| _ -> false


(* Labeled tuple patterns in constructor patterns with that can unify with the
   constructor pattern type. *)
let f = function
| Some (~x:5, 2) -> true
| _ -> false


type t = Foo of (x:int * int)
let f = function
| Foo (~x:5, 2) -> true
| _ -> false


let _ = f (Foo (~x:5,2))
let _ = f (Foo (~x:4,2))
let _ = f (Foo (~x:5,1))


let _ = f (Foo (5,1))


let _ = f (Foo (5,~x:1))


let _ = f (Foo (5,~y:1))

let x = ~x:1, ~y:2


(* Attribute should prevent punning *)
let z = 5
let y = ~z, ~z':z, ~z1:(z [@attr])

let (~x:x0, ~s, ~(y:int), ..) : x:int * s:string * y:int * string =
   ~x: 1, ~s: "a", ~y: 2, "ignore me"


(* Basic expressions *)
let x = ~x:1, ~y:2


let z = 5
let punned = 2
let _ = ~x: 5, 2, ~z, ~(punned:int)


(* Basic annotations *)
let (x : x:int * y:int) = ~x:1, ~y:2


let (x : x:int * int) = ~x:1, 2


(* Incorrect annotations *)
let (x : int * int) = ~x:1, 2


let (x : x:string * int) = ~x:1, 2


let (x : int * y:int) = ~x:1, 2


(* Happy case *)
let foo b = if b then
   ~a: "s", 10, ~c: "hi"
else
   ~a: "5", 10, ~c: "hi"


(* Missing label (the type vars in the error aren't ideal, but the same thing
   happens when unifying normal tuples of different lengths) *)
let foo b = if b then
   ~a: "s", 10, "hi"
else
   ~a: "5", 10, ~c: "hi"


(* Missing labeled component *)
let foo b = if b then
   ~a: "s", 10
else
   ~a: "5", 10, ~c: "hi"


(* Wrong label *)
let foo b = if b then
   ~a: "s", 10, ~b: "hi"
else
   ~a: "5", 10, ~c: "hi"


(* Repeated labels *)
type t = x:int * bool * x:int

let _ = 1, ~x:2, 3, ~x:4


let f (a, ~x, b, ~x:c) = ()


(* Types in function argument/return *)
let default = ~x: 1, ~y: 2
let choose_pt replace_with_default pt =
   if replace_with_default then
      default
   else
      pt


(* Application happy case *)
let a = choose_pt true (~x: 5, ~y: 6)


(* Wrong order *)
let a = choose_pt true (~y: 6, ~x: 5)

(* Mutually-recursive definitions *)
let rec a = 1, ~lbl:b
and b = 2, ~lbl:a


let rec l = ~lbl: 5, ~lbl2: 10 :: l

(* Tuple containing labeled tuples *)
let tup = (~a:1, ~b:2), (~b:3, ~a:4), 5


(* Polymorphic variant containing labeled tuple *)
let a = `Some (~a: 1, ~b:2, 3)


(* List of labeled tuples *)
let lst = ~a: 1, ~b: 2 :: []


(* Ref of labeled tuple *)
let x = ref (~x:"hello", 5)


(* Polymorphic record containing a labeled tuple *)
type 'a box = {thing: 'a}
let boxed = {thing = "hello", ~x:5}


(* Punned tuple components with type annotations. *)
let x = 42
let y = "hi"

let z = ~x, ~(y:string);;


let z = ~(x:int), ~y:"baz";;


let z = ~(x:string), ~y:"baz";;


(* Take a [a:'a * b:'a] and an int, and returns a
   [swapped:[a:'a * b:'a] * same:bool].
   The swapped component is the input with the [a] and [b] components swapped
   as many times as the input int. The second component is whether the first
   equals the input. *)
let rec swap (~a, ~b) =
   function
   | 0 -> ~swapped:(~a, ~b), ~same:true
   | n -> swap' (~a:b, ~b:a) (n-1)
and swap' (~a, ~b) =
   function
   | 0 -> ~swapped:(~a, ~b), ~same:false
   | n -> swap (~a:b, ~b:a) (n-1)


let foobar = swap (~a:"foo", ~b:"bar") 86
let barfoo = swap (~a:"foo", ~b:"bar") 87


(* Labeled tuple type annotations *)
(* Bad type *)
let x: string * a:int * int = ~lbl:5, "hi"


(* Well-typed *)
let x: string * a:int * int = "hi", ~a:1, 2


(* Function type *)
let mk_x : (foo:unit * bar:unit) -> string * a:int * int = fun _ -> x


let x = mk_x (~foo:(), ~bar:())


(* Labeled tuples in records *)

type bad_t = {x : lbl:bad_type * int}


type tx = { x : foo:int * bar:int }
type tx_unlabeled = { x : int * int }



let _ = { x = ~foo:1, ~bar:2}


let _ : tx = { x = ~foo:1, ~bar:2 }


let _ : tx = {x = 1, ~bar:2}


let _ : tx = { x = ~foo:1, 2}


let _ : tx = { x = 1, 2}


let _ = { x = 1, 2 }


(* Module inclusion *)

module IntString : sig
   type t
   val mk : (x: int * string) -> t
   val unwrap : t -> x:int * string
end = struct
  type t = string * x:int
  let mk (~x, s) = s, ~x
  let unwrap (s, ~x) = ~x, s
end


module Stringable = struct
   module type Has_unwrap = sig
      type t
      val unwrap : t -> x: int * string
   end

   module type Has_to_string = sig
      include Has_unwrap
      val to_string : t -> string
   end

   module Make (M : Has_unwrap) : Has_to_string with type t := M.t = struct
      include M
      let to_string int_string =
         let (~x, s) = unwrap int_string in
         (Int.to_string x) ^ " " ^ s
   end
end

module StringableIntString = struct
  module T = struct
    include IntString
  end
  include T
  include Stringable.Make(T)
end


let _ = StringableIntString.to_string (StringableIntString.mk (~x:1, "hi"))


module M : sig
  val f : (x:int * string) -> x:int * string
  val mk : unit -> x:bool * y:string
end = struct
  let f x = x
  let mk () = ~x:false, ~y:"hi"
end

(* Module inclusion failure *)
module X_int_int = struct
   type t = x:int * int
end


module Y_int_int : sig
   type t = y:int * int
end = struct
   include X_int_int
end


module Int_int : sig
   type t = int * int
end = X_int_int


(* Recursive modules *)
module rec Tree : sig
   type t = Leaf of string | Branch of string * TwoTrees.t
   val in_order : t -> string list
end = struct
   type t = Leaf of string | Branch of string * TwoTrees.t
   let rec in_order = function
   | Leaf s -> [s]
   | Branch (s, (~left, ~right)) -> (in_order left) @ [s] @ (in_order right)
end
and TwoTrees : sig
   type t = left:Tree.t * right:Tree.t
end = struct
   type t = left:Tree.t * right:Tree.t
end


let leaf s = Tree.Leaf s
let tree_abc = Tree.Branch ("b", (~left:(leaf "a"), ~right:(leaf "c")))
let tree_abcde = Tree.Branch ("d", (~left:tree_abc, ~right:(leaf "e")))
let _ = Tree.in_order tree_abcde

(* Motivating example *)
let sum_and_product ints =
  let init = ~sum:0, ~product:1 in
  List.fold_left (fun (~sum, ~product) elem ->
    let sum = elem + sum in
    let product = elem * product in
    ~sum, ~product
  ) init ints
let _ = sum_and_product [1;2;3;4]
let _ = sum_and_product [1;-10;2;]


(** Strange syntax test *)

let ~x:(Some Some x), _ = None, 0

let f = ~x, ~y:(fun x -> x)

let _ = ~x:((); 1), 2

let ~(x:int), _ = ~x:0, 1

let _ = ~(x:int), ~(y:int);;

let _ = ~(x:int:>float), ~y, ~z

(** Normalization *)

let ~x:{x=x}, ~y:y, ~z:(z:t), .. = ~x:{x=x}, ~y:y, ~z:(z:t), ~w:(w:t:>t)

(** Comment tests *)
type t = (*before*) x:int * (* after x *) y:(*after y, before the type*)int
  (* after the type, before * *) * (* before the z label *)  z: (*after z label *)float (*end*)

let (*before*) ~(x (*l-ty*):int (*after-ty*)) (*after x*),
    (*before y*) ~y (* after y *), (* bz *) ~z:(*zv*)0 (*end*) =
  (*before*) ~(x (*l-ty*):int (*after-ty*)) (*after x*),
    (*before y*) ~y (* after y *), (* bz *)~z:(*zv*)0 (*end*)

module type T = sig
  val x
    :  from:ttttttttttttttttttttttttttttttttt * ttttttttttttttttttttttttttttttttttt
    -> tttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttt
    -> a
    -> 'b
end