parser.ml 6.27 KB
Newer Older
1 2 3 4
open Location
open Ast

  let gram    = Grammar.create (Plexer.make ())
5
  let prog    = Grammar.Entry.create gram "prog"
6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
  let expr    = Grammar.Entry.create gram "expression"
  let pat     = Grammar.Entry.create gram "type/pattern expression"
  let regexp  = Grammar.Entry.create gram "type/pattern regexp"
  let const   = Grammar.Entry.create gram "scalar constant"
 
  let atom_nil = Types.mk_atom "nil"
		   
  let rec multi_prod loc = function
    | [ x ] -> x
    | x :: l -> mk loc (Prod (x, multi_prod loc l))
    | [] -> assert false

  let rec tuple loc = function
    | [ x ] -> x
    | x :: l -> mk loc (Pair (x, tuple loc l))
    | [] -> assert false
	
  EXTEND
24 25 26
  GLOBAL: prog expr pat regexp const;

  prog: [
27
    [ l = LIST0 [ p = phrase; ";;" -> mk loc p ]; EOI -> l ]
28 29 30 31 32
  ];

  phrase: [
    [ e = expr -> EvalStatement e
    | "type"; x = UIDENT; "="; t = pat -> TypeDecl (x,t) ]
33
  ];
34 35 36 37 38

  expr: [
    "top" RIGHTA
    [ "match"; e = SELF; "with"; b = branches -> mk loc (Match (e,b))
    | "map"; e = SELF; "with"; b = branches -> mk loc (Map (e,b))
39 40
    | "transform"; e = SELF; "with"; b = branches -> 
	mk noloc (Op ("flatten", [mk loc (Map (e,b))]))
41 42 43 44 45 46 47 48
    | "fun"; f = OPT LIDENT; "("; a = LIST1 arrow SEP ";"; ")";
      b = branches -> 
	mk loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
    | (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
        mk loc (Match (e1,[p,e2]))
    ]

    |
49 50
    [ LIDENT "flatten"; e = expr -> mk loc (Op ("flatten",[e]))
    | e1 = expr; e2 = expr -> mk loc (Apply (e1,e2))
51 52
    ]
    
53
    | 
54 55
    [ e1 = expr; "+"; e2 = expr -> mk loc (Op ("+",[e1;e2]))  
    | e1 = expr; "@"; e2 = expr -> mk loc (Op ("@",[e1;e2])) ]
56 57 58
    |
    [ e1 = expr; "*"; e2 = expr -> mk loc (Op ("*",[e1;e2]))  ]

59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
    | "no_appl" 
    [ c = const -> mk loc (Cst c)
    | "("; l = LIST1 expr SEP ","; ")" -> tuple loc l
    | "[";  l = LIST0 expr LEVEL "no_appl"; "]" ->
        tuple loc (l @ [mk noloc (Cst (Types.Atom atom_nil))])
    | "[";  l = LIST0 expr LEVEL "no_appl"; ";"; e = expr; "]" ->
        tuple loc (l @ [e])
    | "<"; t = expr_tag_spec; a = expr_attrib_spec; ">"; c = expr ->
	tuple loc [t;a;c]
    | "{"; r = [ expr_record_spec | -> mk loc (RecordLitt []) ]; "}" -> r
    | a = LIDENT -> mk loc (Var a)
    ]

  ];
	  
  let_binding: [
    [ "let"; p = pat; "="; e = expr -> (p,e)
    | "let"; "fun"; f = LIDENT; "("; a = LIST0 arrow SEP ";"; ")";
      b = branches -> 
        let p = mk loc (Capture f) in
	let abst = { fun_name = Some f; fun_iface = a; fun_body = b } in
        let e = mk loc (Abstraction abst) in
        (p,e)
    ] 
  ];

  arrow: [
86
    [ t1 = pat LEVEL "no_arrow"; "->"; t2 = pat -> (t1,t2)]
87 88 89 90 91 92 93
  ];

  branches: [
    [ OPT "|"; l = LIST1 branch SEP "|" ; OPT "end" -> l ]
  ];

  branch: [
94
    [ p = pat LEVEL "no_arrow"; "->"; e = expr -> (p,e) ]
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
  ];

	  
  regexp: [ 
    [ x = regexp; "|"; y = regexp -> Alt (x,y) ]
  | [ x = regexp; y = regexp -> Seq (x,y) ]
  | [ a = LIDENT; "::"; x = regexp -> SeqCapture (a,x) ]
  | [ x = regexp; "*" -> Star x
    | x = regexp; "*?" -> WeakStar x
    | x = regexp; "+" -> Seq (x, Star x)
    | x = regexp; "+?" -> Seq (x, WeakStar x)
    | x = regexp; "?" -> Alt (x, Epsilon)
    | x = regexp; "??" -> Alt (Epsilon, x) ]
  | [ "("; x = regexp; ")" -> x
    | e = pat LEVEL "simple" -> Elem e
    ]
  ];

  pat: [ 
      [ x = pat; "where"; 
        b = LIST1 [ a = UIDENT; "="; y = pat -> (a,y)] SEP "and"
            -> mk loc (Recurs (x,b)) ]
    | RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y)) ]
118
    | "no_arrow" [ x = pat; "|"; y = pat -> mk loc (Or (x,y)) ] 
119 120 121 122 123 124 125 126 127 128
    | "simple" [ x = pat; "&"; y = pat -> mk loc (And (x,y)) 
      | x = pat; "-"; y = pat -> mk loc (Diff (x,y)) ]
    | 
      [ "{"; r = record_spec; "}" -> r
      | UIDENT "Any" -> mk loc (Internal Types.any)
      | LIDENT "_" -> mk loc (Internal Types.any)
      | a = LIDENT -> mk loc (Capture a)
      | "("; a = LIDENT; ":="; c = const; ")" -> mk loc (Constant (a,c))
      | a = UIDENT -> mk loc (PatVar a)
      | i = INT ; "--"; j = INT -> 
129 130
          let i = Big_int.big_int_of_string i 
	  and j = Big_int.big_int_of_string j in
131
          mk loc (Internal (Types.interval i j))
132 133
      | i = char ; "--"; j = char ->
          mk loc (Internal (Types.char_class i j))
134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
      | c = const -> mk loc (Internal (Types.constant c))
      | "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l
      | "["; r = [ r = regexp -> r | -> Epsilon ];
             q = [ ";"; q = pat -> q 
                 | -> mk noloc (Internal (Types.atom atom_nil)) ]; 
             "]" -> mk loc (Regexp (r,q))
      | "<"; t = tag_spec; a = attrib_spec; ">"; c = pat ->
          multi_prod loc [t;a;c]
      ]
    
  ];

  record_spec:
    [ [ r = LIST0 [ l = [LIDENT | UIDENT]; 
                  o = ["=?" -> true | "=" -> false]; 
                  x = pat ->
                    mk loc (Record (Types.label l,o,x))
                ] SEP ";" ->
        match r with
153 154
          | [] -> mk loc (Internal Types.Record.any)
          | h::t -> List.fold_left (fun t1 t2 -> mk loc (And (t1,t2))) h t
155 156
      ] ];
  
157 158 159 160 161 162 163
  char:
    [ 
      [ c = CHAR -> Chars.Unichar.from_char (Token.eval_char c)
      | "!"; i = INT -> Chars.Unichar.from_int (int_of_string i) ]
    ];
     

164 165
  const:
    [ 
166 167
      [ i = INT -> Types.Integer (Big_int.big_int_of_string i)
(*      | x = STRING -> Types.String (Token.eval_string x) *)
168 169
      | "`"; a = [LIDENT | UIDENT] -> Types.Atom (Types.mk_atom a) 
      | c = char -> Types.Char c ]
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 203
    ];

  tag_spec:
    [
      [ a = [LIDENT | UIDENT] -> 
	  mk loc (Internal (Types.atom (Types.mk_atom a))) ]
    | [ t = pat -> t ]
    ];

  attrib_spec:
    [ [ r = record_spec -> r | "("; t = pat; ")" -> t ] ];

  expr_record_spec:
    [ [ r = LIST1
	      [ l = [LIDENT | UIDENT]; "="; x = expr -> (Types.label l,x) ] 
	      SEP ";" ->
	  mk loc (RecordLitt r)
      ] ];
  
  expr_tag_spec:
    [
      [ a = [LIDENT | UIDENT] -> 
	  mk loc (Cst (Types.Atom (Types.mk_atom a))) ]
    | [ e = expr LEVEL "no_appl" -> e ]
    ];

  expr_attrib_spec:
    [ [ r = expr_record_spec -> r ]
    | [ e = expr LEVEL "no_appl" -> e 
      | -> mk loc (RecordLitt []) 
      ] 
    ];
END

204 205 206
let pat = Grammar.Entry.parse pat
let expr = Grammar.Entry.parse expr
let prog = Grammar.Entry.parse prog
207

208 209 210 211
module From_string = struct
  let pat s = pat (Stream.of_string s)
  let expr s = expr (Stream.of_string s)
end
212