Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 109 lines (97 sloc) 4.028 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 module B = Base
19 let (<|) f a = f a
20 let (|>) a f = f a
21 let ( @* ) g f x = g(f(x))
22 module O = Ocaml
23 module Cons = O.Cons
24 module G = Grammar
25 module T = Tools
26 module L = B.List
27 module A = B.Array
28 module S = B.String
29
30 let tuplize n =
31 let rec aux n acc =
32 if n = 0 then acc
33 else aux (pred n) <| ("__" ^ (string_of_int n)) :: acc
34 in S.concat "," <| aux n []
35
36 let rec rewrite_option n opt next =
37 let sub = rewrite_pattern true 1 opt in
38 let idents = A.of_list <| L.filter T.is_ident opt in
39 let tuple = tuplize <| A.length idents in
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
40 Printf.sprintf "^ (match __%s with None -> \"\" | Some (%s) -> \"\"%s)%s"
fccc685 Initial open-source release
MLstate authored
41 (string_of_int n) tuple sub <| rewrite_pattern false (succ n) next
42
43 and rewrite_subpattern n sub next =
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
44 Printf.sprintf " ^ (String.concat \"\" (List.map (fun (%s) -> \"\"%s) __%s))%s"
fccc685 Initial open-source release
MLstate authored
45 (* (tuplize <| A.length (A.of_list <| L.filter is_ident sub)) *)
46 (L.fold_left T.bruijnise (0, []) sub
47 |> snd
48 |> L.map ((T.prefix "__") @* snd)
49 |> S.concat ","
50 )
51 (rewrite_pattern true 1 sub)
52 (string_of_int n)
53 (rewrite_pattern false (succ n) next)
54
55 and rewrite_pattern in_sub n = function
56 | [] -> ""
57 | G.Prevent _ :: tail -> rewrite_pattern in_sub n tail
58 | G.Literal (s,ci) :: tail -> " ^ " ^ s ^ rewrite_pattern in_sub (succ n) tail
59 | G.SubPattern (_,_,_) :: _ when in_sub -> raise T.NestedSubPatterns
60 | G.SubPattern (_, "?", lst) :: tail -> rewrite_option n lst tail
61 | G.SubPattern (_, _, lst) :: tail -> rewrite_subpattern n lst tail
62 | G.Ident "string" :: tail ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
63 Printf.sprintf " ^ __%s%s" (string_of_int n) <| rewrite_pattern in_sub (succ n) tail
fccc685 Initial open-source release
MLstate authored
64 | G.Ident t :: tail ->
65 let stroft =
66 match t with
67 "int64" -> "Int64.to_string"
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
68 | _ -> Printf.sprintf "string_of_%s" t in
69 Printf.sprintf " ^ (%s __%s)%s" stroft
fccc685 Initial open-source release
MLstate authored
70 (string_of_int n)
71 <| rewrite_pattern in_sub (succ n) tail
72 | _ -> assert false
73
74 let simplify_ident var_lst = function
75 | G.Ident n ->
76 let get_type = function
77 | O.TypeConst t -> T.consttype_to_string t
78 | O.TypeName (_,["int64"]) -> "int64"
79 | O.TypeName (_,["bool"]) -> "bool"
80 | _ -> failwith "Can't convert such a type to string."
81 in G.Ident (get_type <| L.assoc n var_lst)
82 | otherwise -> otherwise
83
84 let pattern_of_define = function
85 | G.Define (G.Constr (name, lst), pattern) -> (
86 try
87 let var_list = L.map T.tuple_of_var lst in
88 let simpl = L.map (simplify_ident var_list) pattern in
89 let verbatim = rewrite_pattern false 1 simpl in
90 let var_lst = snd <| L.fold_left T.bruijnise (0, []) pattern in
91 let var_lst = L.map (fun x -> L.assoc (fst x) var_lst) var_list
92 |> L.map (T.prefix "__")
93 |> L.map (fun s -> O.PatVar (Ident.source s))
94 in O.PatConstructor ([Ident.source name], var_lst), O.Verbatim ("\"\"" ^ verbatim)
95 with
96 | T.NestedSubPatterns ->
a9f8d34 [cleanup] Base: remove sprintf
Raja authored
97 let msg = Printf.sprintf
fccc685 Initial open-source release
MLstate authored
98 "Error in the definition of \"%s\" : sub-patterns cannot be nested"
99 name
100 in failwith msg
101 )
102 | _ -> assert false
103
104 (* Some conversion functions. *)
105 let do_it lst =
106 let tuple_list = L.map pattern_of_define lst in
107 let func = O.Function (L.map (fun (a, b) -> a, None, b) tuple_list) in
108 Ocaml.Let [O.Pat (O.PatVar (Ident.source "string_of_msg")), func]
Something went wrong with that request. Please try again.