helm/software/lambda-delta/components/toplevel/top.ml

   1 (*
   2     ||M||  This file is part of HELM, an Hypertextual, Electronic
   3     ||A||  Library of Mathematics, developed at the Computer Science
   4     ||T||  Department, University of Bologna, Italy.
   5     ||I||
   6     ||T||  HELM is free software; you can redistribute it and/or
   7     ||A||  modify it under the terms of the GNU General Public License
   8     \   /  version 2 or (at your option) any later version.
   9      \ /   This software is distributed as is, NO WARRANTY.
  10       V_______________________________________________________________ *)
  11
  12 module F    = Filename
  13 module P    = Printf
  14 module U    = NUri
  15 module C    = Cps
  16 module L    = Log
  17 module T    = Time
  18 module O    = Options
  19 module H    = Hierarchy
  20 module Op   = Output
  21 module Y    = Entity
  22 module X    = Library
  23 module AL   = AutLexer
  24 module AP   = AutProcess
  25 module AO   = AutOutput
  26 module DT   = CrgTxt
  27 module DA   = CrgAut
  28 module MA   = MetaAut
  29 module MO   = MetaOutput
  30 module ML   = MetaLibrary
  31 module DX   = CrgXml
  32 module DBrg = CrgBrg
  33 module MBrg = MetaBrg
  34 module BrgO = BrgOutput
  35 module BrgR = BrgReduction
  36 module BrgU = BrgUntrusted
  37 module MBag = MetaBag
  38 module BagO = BagOutput
  39 module BagT = BagType
  40 module BagU = BagUntrusted
  41
  42 type status = {
  43    ast : AP.status;
  44    dst : DA.status;
  45    mst : MA.status;
  46    tst : DT.status;
  47    ac  : AO.counters;
  48    mc  : MO.counters;
  49    brgc: BrgO.counters;
  50    bagc: BagO.counters;
  51    kst : Y.status
  52 }
  53
  54 let flush_all () = L.flush 0; L.flush_err ()
  55
  56 let bag_error s msg =
  57    L.error BagO.specs (L.Warn s :: L.Loc :: msg); flush_all ()
  58
  59 let brg_error s msg =
  60    L.error BrgR.specs (L.Warn s :: L.Loc :: msg); flush_all ()
  61
  62 let initial_status () = {
  63    ac   = AO.initial_counters;
  64    mc   = MO.initial_counters;
  65    brgc = BrgO.initial_counters;
  66    bagc = BagO.initial_counters;
  67    mst  = MA.initial_status ();
  68    dst  = DA.initial_status ();
  69    tst  = DT.initial_status ();
  70    ast  = AP.initial_status ();
  71    kst  = Y.initial_status ()
  72 }
  73
  74 let refresh_status st = {st with
  75    mst = MA.refresh_status st.mst;
  76    dst = DA.refresh_status st.dst;
  77    tst = DT.refresh_status st.tst;
  78    kst = Y.refresh_status st.kst
  79 }
  80
  81 (* kernel related ***********************************************************)
  82
  83 type kernel = Brg | Bag
  84
  85 type kernel_entity = BrgEntity  of Brg.entity
  86                    | BagEntity  of Bag.entity
  87                    | CrgEntity  of Crg.entity
  88                    | MetaEntity of Meta.entity
  89
  90 let kernel = ref Brg
  91
  92 let print_counters st = match !kernel with
  93    | Brg -> BrgO.print_counters C.start st.brgc
  94    | Bag -> BagO.print_counters C.start st.bagc
  95
  96 let xlate_entity entity = match !kernel, entity with
  97    | Brg, CrgEntity e  ->
  98       let f e = (BrgEntity e) in Y.xlate f DBrg.brg_of_crg e
  99    | Brg, MetaEntity e ->
 100       let f e = (BrgEntity e) in Y.xlate f MBrg.brg_of_meta e
 101    | Bag, MetaEntity e ->
 102       let f e = (BagEntity e) in Y.xlate f MBag.bag_of_meta e
 103    | _, entity         -> entity
 104
 105 let pp_progress e =
 106    let f a u =
 107       let s = U.string_of_uri u in
 108       let err () = L.warn (P.sprintf "%s" s) in
 109       let f i = L.warn (P.sprintf "[%u] %s" i s) in
 110       Y.mark err f a
 111    in
 112    match e with
 113       | CrgEntity e -> Y.common f e
 114       | BrgEntity e -> Y.common f e
 115       | BagEntity e -> Y.common f e
 116       | MetaEntity e -> Y.common f e
 117
 118 let count_entity st = function
 119    | MetaEntity e -> {st with mc = MO.count_entity C.start st.mc e}
 120    | BrgEntity e  -> {st with brgc = BrgO.count_entity C.start st.brgc e}
 121    | BagEntity e  -> {st with bagc = BagO.count_entity C.start st.bagc e}
 122    | _            -> st
 123
 124 let export_entity si xdir moch = function
 125    | CrgEntity e  -> X.export_entity DX.export_term si xdir e
 126    | BrgEntity e  -> X.export_entity BrgO.export_term si xdir e
 127    | MetaEntity e ->
 128       begin match moch with
 129          | None     -> ()
 130          | Some och -> ML.write_entity C.start och e
 131       end
 132    | BagEntity _  -> ()
 133
 134 let type_check st k =
 135    let brg_err msg = brg_error "Type Error" msg; failwith "Interrupted" in
 136    let ok _ _ = st in
 137    match k with
 138       | BrgEntity entity -> BrgU.type_check brg_err ok st.kst entity
 139       | BagEntity entity -> BagU.type_check ok st.kst entity
 140       | CrgEntity _
 141       | MetaEntity _     -> st
 142
 143 (* extended lexer ***********************************************************)
 144
 145 type 'token lexer = {
 146    parse : Lexing.lexbuf -> 'token;
 147    mutable tokbuf: 'token option;
 148    mutable unget : bool
 149 }
 150
 151 let initial_lexer parse = {
 152    parse = parse; tokbuf = None; unget = false
 153 }
 154
 155 let token xl lexbuf = match xl.tokbuf with
 156    | Some token when xl.unget ->
 157       xl.unget <- false; token
 158    | _                        ->
 159       let token = xl.parse lexbuf in
 160       xl.tokbuf <- Some token; token
 161
 162 (* input related ************************************************************)
 163
 164 type input = Text | Automath
 165
 166 type input_entity = TxtEntity of Txt.command
 167                   | AutEntity of Aut.command
 168                   | NoEntity
 169
 170 let type_of_input name =
 171    if F.check_suffix name ".hln" then Text
 172    else if F.check_suffix name ".aut" then
 173       let _ = H.set_sorts 0 ["Set"; "Prop"] in
 174       assert (H.set_graph "Z2");
 175       Automath
 176    else begin
 177       L.warn (P.sprintf "Unknown file type: %s" name); exit 2
 178    end
 179
 180 let txt_xl = initial_lexer TxtLexer.token
 181
 182 let aut_xl = initial_lexer AutLexer.token
 183
 184 let parbuf = ref [] (* parser buffer *)
 185
 186 let gen_text command =
 187    parbuf := TxtEntity command :: !parbuf
 188
 189 let entity_of_input lexbuf i = match i, !parbuf with
 190    | Automath, _    ->
 191       begin match AutParser.entry (token aut_xl) lexbuf with
 192          | Some e -> aut_xl.unget <- true; AutEntity e
 193          | None   -> NoEntity
 194       end
 195    | Text, []       ->
 196       begin match TxtParser.entry (token txt_xl) lexbuf with
 197          | Some e -> txt_xl.unget <- true; TxtEntity e
 198          | None   -> NoEntity
 199       end
 200    | Text, hd :: tl ->
 201       parbuf := tl; hd
 202
 203 let process_input f st = function
 204    | AutEntity e     ->
 205       let f ast e = f {st with ast = ast} (AutEntity e) in
 206       AP.process_command f st.ast e
 207    | xe              -> f st xe
 208
 209 let count_input st = function
 210    | AutEntity e -> {st with ac = AO.count_command C.start st.ac e}
 211    | xe          -> st
 212
 213 (****************************************************************************)
 214
 215 let stage = ref 3
 216 let moch = ref None
 217 let meta = ref false
 218 let progress = ref false
 219 let preprocess = ref false
 220 let root = ref ""
 221 let cc = ref false
 222 let export = ref ""
 223 let old = ref false
 224 let st = ref (initial_status ())
 225 let streaming = ref false (* parsing style (temporary) *)
 226
 227 let process_2 st entity =
 228    let st = if !L.level > 2 then count_entity st entity else st in
 229    if !export <> "" then export_entity !O.si !export !moch entity;
 230    if !stage > 2 then type_check st entity else st
 231
 232 let process_1 st entity =
 233    if !progress then pp_progress entity;
 234    let st = if !L.level > 2 then count_entity st entity else st in
 235    if !export <> "" && !stage = 1 then export_entity !O.si !export !moch entity;
 236    if !stage > 1 then process_2 st (xlate_entity entity) else st
 237
 238 let process_0 st entity =
 239    let f st entity =
 240       if !stage = 0 then st else
 241       match entity, !old with
 242          | AutEntity e, true  ->
 243             let frr mst = {st with mst = mst} in
 244             let h mst e = process_1 {st with mst = mst} (MetaEntity e) in
 245             MA.meta_of_aut frr h st.mst e
 246          | AutEntity e, false ->
 247             let err dst = {st with dst = dst} in
 248             let g dst e = process_1 {st with dst = dst} (CrgEntity e) in
 249             DA.crg_of_aut err g st.dst e
 250          | TxtEntity e, _     ->
 251             let crr tst = {st with tst = tst} in
 252             let d tst e = process_1 {st with tst = tst} (CrgEntity e) in
 253             DT.crg_of_txt crr d gen_text st.tst e
 254          | NoEntity, _        -> assert false
 255    in
 256    let st = if !L.level > 2 then count_input st entity else st in
 257    if !preprocess then process_input f st entity else f st entity
 258
 259 let process_nostreaming st lexbuf input =
 260    let rec aux1 book = match entity_of_input lexbuf input with
 261       | NoEntity -> List.rev book
 262       | e        -> aux1 (e :: book)
 263    in
 264    let rec aux2 st = function
 265       | []           -> st
 266       | entity :: tl -> aux2 (process_0 st entity) tl
 267    in
 268    aux2 st (aux1 [])
 269
 270 let rec process_streaming st lexbuf input = match entity_of_input lexbuf input with
 271    | NoEntity -> st
 272    | e        -> process_streaming (process_0 st e) lexbuf input
 273
 274 (****************************************************************************)
 275
 276 let process st name =
 277    let process = if !streaming then process_streaming else process_nostreaming in
 278    let input = type_of_input name in
 279    let ich = open_in name in
 280    let lexbuf = Lexing.from_channel ich in
 281    let st = process st lexbuf input in
 282    close_in ich; st, input
 283
 284 let main =
 285 try
 286    let version_string = "Helena 0.8.1 M - August 2010" in
 287    let print_version () = L.warn (version_string ^ "\n"); exit 0 in
 288    let set_hierarchy s =
 289       if H.set_graph s then () else
 290          L.warn (P.sprintf "Unknown type hierarchy: %s" s)
 291    in
 292    let set_kernel = function
 293       | "brg" -> kernel := Brg
 294       | "bag" -> kernel := Bag
 295       | s     -> L.warn (P.sprintf "Unknown kernel version: %s" s)
 296    in
 297    let set_summary i = L.level := i in
 298    let set_stage i = stage := i in
 299    let set_meta_file name =
 300       let f och = moch := Some och in
 301       ML.open_out f name
 302    in
 303    let set_xdir s = export := s in
 304    let set_root s = root := s in
 305    let close = function
 306       | None     -> ()
 307       | Some och -> ML.close_out C.start och
 308    in
 309    let clear_options () =
 310       stage := 3; moch := None; meta := false; progress := false;
 311       preprocess := false; root := ""; cc := false; export := "";
 312       old := false; kernel := Brg; st := initial_status ();
 313       L.clear (); O.clear (); H.clear (); Op.clear_reductions ();
 314       streaming := false;
 315    in
 316    let process_file name =
 317       if !L.level > 0 then T.gmtime version_string;
 318       if !L.level > 1 then
 319          L.warn (P.sprintf "Processing file: %s" name);
 320       if !L.level > 0 then T.utime_stamp "started";
 321       let base_name = Filename.chop_extension (Filename.basename name) in
 322       if !meta then set_meta_file base_name;
 323       let mk_uri =
 324          if !stage < 2 then Crg.mk_uri else
 325          match !kernel with
 326             | Brg -> Brg.mk_uri
 327             | Bag -> Bag.mk_uri
 328       in
 329       let cover = F.concat !root base_name in
 330       O.mk_uri := mk_uri; O.cover := cover;
 331       let sst, input = process (refresh_status !st) name in
 332       st := sst;
 333       if !L.level > 0 then T.utime_stamp "processed";
 334       if !L.level > 2 then begin
 335          AO.print_counters C.start !st.ac;
 336          if !preprocess then AO.print_process_counters C.start !st.ast;
 337          if !stage > 0 then MO.print_counters C.start !st.mc;
 338          if !stage > 1 then print_counters !st;
 339          if !stage > 2 then Op.print_reductions ()
 340       end
 341    in
 342    let exit () =
 343       close !moch;
 344       if !L.level > 0 then T.utime_stamp "at exit";
 345       flush_all ()
 346    in
 347    let help =
 348       "Usage: helena [ -LPVXcgijmopqu1 | -Ss <number> | -x <dir> | -hkr <string> ]* [ <file> ]*\n\n" ^
 349       "Summary levels: 0 just errors (default), 1 time stamps, 2 processed file names, \
 350        3 data information, 4 typing information, 5 reduction information\n\n" ^
 351        "Stages: 0 parsing, 1 to intermediate, 2 to untrusted, 3 to trusted (default)\n"
 352    in
 353    let help_L = " show lexer debug information" in
 354    let help_P = " show parser debug information" in
 355    let help_S = "<number>  set summary level (see above)" in
 356    let help_V = " show version information" in
 357    let help_X = " clear options" in
 358
 359    let help_c = " output conversion constraints" in
 360    let help_g = " always expand global definitions" in
 361    let help_h = "<string>  set type hierarchy (default: Z1)" in
 362    let help_i = " show local references by index" in
 363    let help_j = " show URI of processed kernel objects" in
 364    let help_k = "<string>  set kernel version (default: brg)" in
 365    let help_m = " output intermediate representation (HAL)" in
 366    let help_o = " use old abstract language instead of crg" in
 367    let help_p = " preprocess source" in
 368    let help_q = " disable quotation of identifiers" in
 369    let help_r = "<string>  set initial segment of URI hierarchy" in
 370    let help_s = "<number>  set translation stage (see above)" in
 371    let help_u = " activate sort inclusion" in
 372    let help_x = "<dir>  export kernel entities (XML) to <dir>" in
 373
 374    let help_1 = " parse files with streaming policy" in
 375    L.box 0; L.box_err ();
 376    at_exit exit;
 377    Arg.parse [
 378       ("-L", Arg.Set O.debug_lexer, help_L);
 379       ("-P", Arg.Set O.debug_parser, help_P);
 380       ("-S", Arg.Int set_summary, help_S);
 381       ("-V", Arg.Unit print_version, help_V);
 382       ("-X", Arg.Unit clear_options, help_X);
 383       ("-c", Arg.Set cc, help_c);
 384       ("-g", Arg.Set O.expand, help_g);
 385       ("-h", Arg.String set_hierarchy, help_h);
 386       ("-i", Arg.Set O.indexes, help_i);
 387       ("-j", Arg.Set progress, help_j);
 388       ("-k", Arg.String set_kernel, help_k);
 389       ("-m", Arg.Set meta, help_m);
 390       ("-o", Arg.Set old, help_o);
 391       ("-p", Arg.Set preprocess, help_p);
 392       ("-q", Arg.Set O.unquote, help_q);
 393       ("-r", Arg.String set_root, help_r);
 394       ("-s", Arg.Int set_stage, help_s);
 395       ("-u", Arg.Set O.si, help_u);
 396       ("-x", Arg.String set_xdir, help_x);
 397       ("-1", Arg.Set streaming, help_1);
 398    ] process_file help;
 399 with BagT.TypeError msg -> bag_error "Type Error" msg