ast.ml 5.14 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 36 37
and toplevel_directive =
  [ `Quit
  | `Env
38
  | `Reinit_ns
39
  | `Help of string option
40
  | `Dump of pexpr
41
  | `Print_type of ppat
42
  | `Debug of debug_directive
43 44
  | `Verbose
  | `Silent
45
  | `Builtins
46
  ]
47

48
and pexpr =
49 50
  | LocatedExpr of loc * pexpr

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

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

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

  (* Exceptions *)
  | Try of pexpr * branches

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

86 87
  (* CQL *)
  | SelectFW of pexpr * (ppat * pexpr) list * pexpr list
88

89 90
and label = U.t

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

and branches = (ppat * pexpr) list
98 99

(* A common syntactic class for patterns and types *)
100 101 102

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

126 127


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

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

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


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

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
170 171 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


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