Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 131 lines (114 sloc) 5.223 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 (* rebel open *)
19 open SurfaceAst
20 open SurfaceAstHelper
21 open OpaEnv
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support…
OpaOnWindowsNow authored
22 open SurfaceAstPassesTypes
fccc685 Initial open-source release
MLstate authored
23
24 (* refactoring in progress *)
25
26 (* alias *)
27 module C = SurfaceAstCons.ExprIdentCons
28 module CS = SurfaceAstCons.StringCons
29
30
31
32 let pass_load_objects ~options (special_parsed_files, user_parsed_files) k =
33 let extract_package_decl = function
34 | (Package ((`declaration | `import) as kind, name), label) ->
35 Some (kind, name, label.QmlLoc.pos)
36 | _ -> None in
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support…
OpaOnWindowsNow authored
37 let extract_current_package_name = function
38 | Package (`declaration, name), _label -> Some(name)
39 | _ -> None in
40 let package_name code = Base.List.find_map extract_current_package_name code in
41 let label s = {QmlLoc.pos=FilePos.nopos ("i18n, import "^s); QmlLoc.notes=SurfaceAstCons.Fresh.id()} in
fccc685 Initial open-source release
MLstate authored
42 let map { parsedFile_lcode = code; parsedFile_filename = name; parsedFile_content = content } =
4692879 @OpaOnWindowsNow [feature] Internationalisation: add @i18n directive and start support…
OpaOnWindowsNow authored
43 let exists = ObjectFiles.exists_package ~extrapath:options.OpaEnv.extrapath in
44 let package = package_name code in
45 (* adding internationalisation import *)
46 let i18n_to_import = I18nAndComputedString.may_import_package ?package ~exists ~options in
47 let imports = List.map (fun s -> Package(`import, s), label s) i18n_to_import in
48 (name,content,imports @ code)
49 in
fccc685 Initial open-source release
MLstate authored
50 ObjectFiles.set_extrapaths ~no_stdlib:(not options.OpaEnv.stdlib) options.OpaEnv.extrapath;
51 ObjectFiles.load
52 ~extrajs:(
53 (*
54 TODO(if needed): we can patch ObjectFiles for passing the conf as well
55 *)
56 List.map fst options.OpaEnv.extrajs
57 )
58 ~no_stdlib:(not options.OpaEnv.stdlib)
59 extract_package_decl
60 (SurfaceAstStaticInclude.pass_analyse_static_include_deps ~options)
61 (List.map map special_parsed_files @ List.map map user_parsed_files)
62 k
63
64 let pass_parser_generation
65 ~options:_ (env : (string,parsing_directive) env_both_lcodes)
66 : (string,renaming_directive) env_both_lcodes =
67 let rewrite code =
68 (* map_down because the directive `xml_parser may contain parsers *)
69 SurfaceAstTraversal.ExprTraverse.Heterogeneous.lift_map_down_to_fixpoint
70 (function (* the filter function, to make the typer happy *)
71 | #renaming_directive as x -> x
72 | #parsing_directive -> assert false)
73 (function (* the actual mapping function *)
74 | (Directive (`parser_ e, [], _), label) ->
75 SurfaceAstCons.with_label' label SurfaceAstTrx.translate_rule e
76 | (Directive (`xml_parser xml_parser, [], _), label) as e ->
77 SurfaceAstCons.with_label' label (SurfaceAstXmlPattern.process_parser e) xml_parser
78 | e -> e) code in
79 { env with
80 lcodeNotUser = rewrite env.lcodeNotUser;
81 lcodeUser = rewrite env.lcodeUser;
82 }
83
84 (**
85 Check for duplication of idents and some more.
86
87 This pass
88 - checks for level-0 identifiers with two definitions -- having two definitions of the same level-0 identifier
89 is either a warning or an error, depending on options
90 - renames all identifiers to make them unique
91
92 If the option [--warn-error duplicateL0] is set, having two level-0 identifiers with the same name is cause for
93 an error. Otherwise, it's an warning.
94 *)
95
96 let pass_check_duplication
97 compiler_inserted_names compiler_inserted_types ~options:_
98 (env : (string,renaming_directive) env_both_lcodes)
99 : (Ident.t,dependency_directive) env_both_lcodes =
100 let envs = SurfaceAstRenaming.init_env compiler_inserted_names compiler_inserted_types in
101 let envs = SurfaceAstRenaming.load_env envs in
102 let envs, lcodeNotUser = SurfaceAstRenaming.code envs env.lcodeNotUser in
103 let envs, lcodeUser = SurfaceAstRenaming.code envs env.lcodeUser in
104 SurfaceAstRenaming.save_env envs;
105 {
106 env with
107 lcodeNotUser ;
108 lcodeUser ;
109 lcodeTypeRenaming = SurfaceAstRenaming.extract_types_in_scope envs;
110 exported_values_idents = SurfaceAstRenaming.get_exported_values envs
111 }
112
113
114 let pass_tuple_types ~options:_ lcode =
115 SurfaceAstCons.with_builtin_position
116 (fun () ->
117 let intmap = SurfaceAstRenaming.get_tuple_int_map () in
118 let typedefs =
119 IntMap.fold
120 (fun n ident acc ->
121 let name = Printf.sprintf "tuple_%d" n in
122 let var d = Printf.sprintf "%s_%d" name d in
123 let vars = List.init n (fun n -> Ident.next (var n)) in
124 C.T.typedef
125 SurfaceAst.TDV_public ident ~tyvs: (List.map flatvar vars)
126 (C.T.tuple (List.map C.T.var vars))
127 :: acc)
128 intmap [] in
129 let defs = List.map C.C.newtype typedefs in
130 defs @ lcode)
Something went wrong with that request. Please try again.