(*  Abstract syntax as produced by the parser *)

open Cduce_loc
open Ident

type ns_expr = [ `Uri of Ns.Uri.t | `Path of U.t list ]

(* located ident *)
type lident = (Cduce_loc.loc * U.t)

type pprog = pmodule_item list

and pmodule_item = pmodule_item' located
and pmodule_item' =
  | TypeDecl of (lident * U.t list * ppat)
  | SchemaDecl of U.t * string
  | LetDecl of ppat * pexpr
  | FunDecl of pexpr
  | Namespace of U.t * ns_expr
  | KeepNs of bool
  | Using of U.t * U.t
  | Open of U.t list
  | EvalStatement of pexpr
  | Directive of toplevel_directive
and debug_directive =
  [ `Filter of ppat * ppat
  | `Sample of ppat
  | `Accept of ppat
  | `Compile of ppat * ppat list
  | `Subtype of ppat * ppat
  | `Single of ppat
  | `Typed of pexpr
  | `Lambda of pexpr
  | `Bdd of ppat
  | `Id_bdd of int
  ]
and toplevel_directive =
  [ `Quit
  | `Env
  | `Reinit_ns
  | `Help of string option
  | `Dump of pexpr
  | `Print_type of ppat
  | `Debug of debug_directive
  | `Verbose
  | `Silent
  | `Builtins
  ]

and pexpr =
  | LocatedExpr of loc * pexpr

  (* CDuce is a Lambda-calculus ... *)
  | Var of U.t
  | Apply of pexpr * pexpr
  | Abstraction of abstr

  (* Data constructors *)
  | Const of Types.Const.t
  | Integer of Intervals.V.t
  | Char of Chars.V.t
  | Pair of pexpr * pexpr
  | Atom of U.t
  | Xml of pexpr * pexpr
  | RecordLitt of (label * pexpr) list
  | String of U.uindex * U.uindex * U.t * pexpr

  (* Data destructors *)
  | Match of pexpr * branches
  | Map of pexpr * branches
  | Transform of pexpr * branches
  | Xtrans of pexpr * branches
  | Validate of pexpr * U.t list
  | Dot of pexpr * label
  | TyArgs of pexpr * ppat list
  | RemoveField of pexpr * label

  (* Exceptions *)
  | Try of pexpr * branches

  (* Other *)
  | NamespaceIn of U.t * ns_expr * pexpr
  | KeepNsIn of bool * pexpr
  | Forget of pexpr * ppat
  | Check of pexpr * ppat
  | Ref of pexpr * ppat

  (* CQL *)
  | SelectFW of pexpr * (ppat * pexpr) list * pexpr list

and label = U.t

and abstr = {
  fun_name : lident option;
  fun_iface : (ppat * ppat) list;
  fun_body : branches
}

and branches = (ppat * pexpr) list

(* A common syntactic class for patterns and types *)

and ppat = ppat' located
and ppat' =
  | PatVar of (U.t list * ppat list)
  | Cst of pexpr
  | NsT of U.t
  | Recurs of ppat * (lident * U.t list * ppat) list
  | Internal of Types.descr
  | Or of ppat * ppat
  | And of ppat * ppat
  | Diff of ppat * ppat
  | Prod of ppat * ppat
  | XmlT of ppat * ppat
  | Arrow of ppat * ppat
  | Optional of ppat
  | Record of bool * (label * (ppat * ppat option)) list
      (* Record (o, (l,(p1, p2)) list )
         o : true => open record
         l : field label
         p1 : pattern expression (Optional if l=?pat )
         p2 : Some p3 => else p3 *)
  | Constant of U.t * pexpr
  | Regexp of regexp
  | Concat of ppat * ppat
  | Merge of ppat * ppat



and regexp =
  | Epsilon
  | Elem of ppat
  | Guard of ppat
  | Seq of regexp * regexp
  | Alt of regexp * regexp
  | Star of regexp
  | WeakStar of regexp
  | SeqCapture of lident * regexp
  | Arg of regexp

let pat_true = mknoloc (Internal Builtin_defs.true_type)
let pat_false = mknoloc (Internal Builtin_defs.false_type)
let cst_true = Const (Types.Atom Builtin_defs.true_atom)
let cst_false = Const (Types.Atom Builtin_defs.false_atom)

let cst_nil = Const Sequence.nil_cst
let pat_nil = mknoloc (Internal (Sequence.nil_type))


let rec prod_to_list p =
  match p.descr with
  Prod(p1, p2) -> p1 :: (prod_to_list p2)
  | _ -> [ p ]

let re_seq e1 e2 =
  match e1, e2 with
  Epsilon, _ -> e2
  | _, Epsilon -> e1
  | _ -> Seq (e1, e2)

let rec print_re fmt e =
  match e with
    Epsilon -> Format.fprintf fmt "Epsilon"
  | Elem _ -> Format.fprintf fmt "Elem"
  | Guard _ -> Format.fprintf fmt "Guard"
  | Seq (e1, e2) -> Format.fprintf fmt "Seq(%a, %a)" print_re e1 print_re e2
  | Alt (e1, e2) -> Format.fprintf fmt "Alt(%a, %a)" print_re e1 print_re e2
  | Star (e0) -> Format.fprintf fmt "Star(%a)" print_re e0
  | WeakStar (e0) -> Format.fprintf fmt "WeakStar(%a)" print_re e0
  | SeqCapture (_, e0) -> Format.fprintf fmt "SeqCapture(_, %a)" print_re e0
  | Arg (e0) -> Format.fprintf fmt "Arg(%a)" print_re e0


let rec pat_fold f acc p =
  let nacc = f acc p in
  match p.descr with
  | PatVar _ | Cst _ | NsT _
  | Internal _ | Constant _ -> nacc
  | Recurs (p0, pl) ->
    List.fold_left (fun acc (_,_,pi) -> pat_fold f acc pi) (pat_fold f nacc p0) pl

  | Or (p1, p2) | And (p1, p2)
  | Diff (p1, p2) | Prod (p1, p2)
  | XmlT (p1, p2) | Arrow (p1, p2)
  | Concat (p1, p2) | Merge  (p1, p2) -> pat_fold f (pat_fold f nacc p1) p2

  | Optional p0 -> pat_fold f nacc p0
  | Record (_, pl) -> List.fold_left (fun acc (_,(p1, op2)) ->
    let acc1 = pat_fold f nacc p1 in
    match op2 with None -> acc1 | Some p2 -> pat_fold f acc1 p2) nacc pl
  | Regexp e -> re_fold (fun acc e -> match e with Elem p -> pat_fold f acc p | _ -> acc) nacc e

and re_fold f acc e =
  let nacc = f acc e in
  match e with
  | Epsilon  | Elem _ | Guard _ -> nacc
  | Seq (e1, e2)
  | Alt (e1, e2) -> re_fold f (re_fold f nacc e1) e2
  | Star (e0) | WeakStar (e0)
  | SeqCapture (_, e0) | Arg (e0) -> re_fold f nacc e0


let pat_iter f p = pat_fold (fun () p -> f p) () p
let re_iter f e = re_fold (fun () e -> f e) () e