ast.ml 5.17 KB
Newer Older
1
(*  Abstract syntax as produced by the parser *)
2

3
open Cduce_loc
4
open Ident
5

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

Pietro Abate's avatar
Pietro Abate committed
8 9 10
(* located ident *)
type lident = (Cduce_loc.loc * U.t)

11 12 13 14
type pprog = pmodule_item list

and pmodule_item = pmodule_item' located
and pmodule_item' =
Pietro Abate's avatar
Pietro Abate committed
15
  | TypeDecl of (lident * U.t list * ppat)
16
  | SchemaDecl of U.t * string
17
  | LetDecl of ppat * pexpr
18
  | FunDecl of pexpr
19
  | Namespace of U.t * ns_expr
20
  | KeepNs of bool
21
  | Using of U.t * U.t
22
  | Open of U.t list
23
  | EvalStatement of pexpr
24
  | Directive of toplevel_directive
25 26
and debug_directive =
  [ `Filter of ppat * ppat
27
  | `Sample of ppat
28
  | `Accept of ppat
29
  | `Compile of ppat * ppat list
30
  | `Subtype of ppat * ppat
31
  | `Single of ppat
32 33
  | `Typed of pexpr
  | `Lambda of pexpr
34 35
  | `Bdd of ppat
  | `Id_bdd of int
36
  ]
37 38 39
and toplevel_directive =
  [ `Quit
  | `Env
40
  | `Reinit_ns
41
  | `Help of string option
42
  | `Dump of pexpr
43
  | `Print_type of ppat
44
  | `Debug of debug_directive
45 46
  | `Verbose
  | `Silent
47
  | `Builtins
48
  ]
49

50
and pexpr =
51 52
  | LocatedExpr of loc * pexpr

53
  (* CDuce is a Lambda-calculus ... *)
54
  | Var of U.t
55 56
  | Apply of pexpr * pexpr
  | Abstraction of abstr
57

58
  (* Data constructors *)
59
  | Const of Types.Const.t
60 61
  | Integer of Intervals.V.t
  | Char of Chars.V.t
62
  | Pair of pexpr * pexpr
63
  | Atom of U.t
64
  | Xml of pexpr * pexpr
65
  | RecordLitt of (label * pexpr) list
66
  | String of U.uindex * U.uindex * U.t * pexpr
67

68 69
  (* Data destructors *)
  | Match of pexpr * branches
70 71
  | Map of pexpr * branches
  | Transform of pexpr * branches
72
  | Xtrans of pexpr * branches
73 74 75
  | Validate of pexpr * U.t list
  | Dot of pexpr * label
  | TyArgs of pexpr * ppat list
76
  | RemoveField of pexpr * label
77 78 79 80

  (* Exceptions *)
  | Try of pexpr * branches

81
  (* Other *)
82
  | NamespaceIn of U.t * ns_expr * pexpr
83
  | KeepNsIn of bool * pexpr
84
  | Forget of pexpr * ppat
85
  | Check of pexpr * ppat
86 87
  | Ref of pexpr * ppat

88 89
  (* CQL *)
  | SelectFW of pexpr * (ppat * pexpr) list * pexpr list
90

91 92
and label = U.t

93 94
and abstr = {
  fun_name : lident option;
95 96 97 98 99
  fun_iface : (ppat * ppat) list;
  fun_body : branches
}

and branches = (ppat * pexpr) list
100 101

(* A common syntactic class for patterns and types *)
102 103 104

and ppat = ppat' located
and ppat' =
Pietro Abate's avatar
Pietro Abate committed
105
  | PatVar of (U.t list * ppat list)
106
  | Cst of pexpr
107
  | NsT of U.t
Pietro Abate's avatar
Pietro Abate committed
108
  | Recurs of ppat * (lident * U.t list * ppat) list
109 110
  | Internal of Types.descr
  | Or of ppat * ppat
111
  | And of ppat * ppat
112 113
  | Diff of ppat * ppat
  | Prod of ppat * ppat
114
  | XmlT of ppat * ppat
115
  | Arrow of ppat * ppat
116
  | Optional of ppat
117
  | Record of bool * (label * (ppat * ppat option)) list
118 119 120 121 122
      (* 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 *)
123
  | Constant of U.t * pexpr
124
  | Regexp of regexp
125
  | Concat of ppat * ppat
126
  | Merge of ppat * ppat
127

128 129


130 131 132
and regexp =
  | Epsilon
  | Elem of ppat
133
  | Guard of ppat
134 135 136 137
  | Seq of regexp * regexp
  | Alt of regexp * regexp
  | Star of regexp
  | WeakStar of regexp
Pietro Abate's avatar
Pietro Abate committed
138
  | SeqCapture of lident * regexp
139
  | Arg of regexp
140

141
let pat_true = mknoloc (Internal Builtin_defs.true_type)
142
let pat_false = mknoloc (Internal Builtin_defs.false_type)
143 144 145
let cst_true = Const (Types.Atom Builtin_defs.true_atom)
let cst_false = Const (Types.Atom Builtin_defs.false_atom)

146
let cst_nil = Const Sequence.nil_cst
147
let pat_nil = mknoloc (Internal (Sequence.nil_type))
148 149 150 151 152 153 154 155 156 157 158 159


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)
160 161 162 163 164 165 166 167 168 169 170 171

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
172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204


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