1(* Parsspec -- parse Moscow ML signature files.
2
3*)
4
5open BasicIO List
6
7(* Lexer of stream *)
8
9fun createLexerStream (is : instream) =
10  Lexing.createLexer (fn buff => fn n => Nonstdio.buff_input is buff 0 n)
11;
12
13fun parsePhraseAndClear parsingFun lexingFun lexbuf =
14  let val phr =
15    parsingFun lexingFun lexbuf
16    handle x => (Parsing.clearParser(); raise x)
17  in
18    Parsing.clearParser();
19    phr
20  end;
21
22val parseSpec =
23  parsePhraseAndClear Parser.SigFile Lexer.Token;
24
25fun processSpec is str ((Location.Loc(pos1, pos2), spec), res) =
26    let fun getline line pos =
27	    if pos < pos1 then
28		case Nonstdio.input_char is of
29		    #"\^Z" => raise Fail "Parsspec.processSpec: internal error"
30		  | #"\n"  => getline (line+1) (pos+1)
31		  | _      => getline line (pos+1)
32	    else line
33	val lineno = (Nonstdio.seek_in is 0; getline 0 0)
34	open Asynt Database
35	fun getId ({qualid = {id, ...}, ...} : IdInfo) = hd id
36	fun valdesc ((idInfo, ty), res) =
37	    {comp = Val (getId idInfo), file = str, line = lineno} :: res
38	fun pvaldesc ((idInfo, ty, arity, cfun), res) =
39	    {comp = Val (getId idInfo), file = str, line = lineno} :: res
40	fun typdesc ((tyvars, idInfo), res) =
41	    {comp = Typ (getId idInfo), file = str, line = lineno} :: res
42	fun typbind ((tyvars, idInfo, ty), res) =
43	    {comp = Typ (getId idInfo), file = str, line = lineno} :: res
44	fun conbind ((ConBind(idInfo, tyOpt)), res) =
45	    {comp = Con (getId idInfo), file = str, line = lineno} :: res
46	fun datbind ((tyvars, idInfo, cbs), res) =
47	    {comp = Typ (getId idInfo), file = str, line = lineno}
48	    :: foldl conbind res cbs
49	fun datrep (idInfo, res) =
50	    {comp = Typ (getId idInfo), file = str, line = lineno} :: res
51	fun exdesc ((idInfo, tyOpt), res) =
52	    {comp = Exc (getId idInfo), file = str, line = lineno} :: res
53    in
54	case spec of
55	    VALspec vs                  => foldl valdesc res vs
56	  | PRIM_VALspec pvs            => foldl pvaldesc res pvs
57	  | TYPEDESCspec (tnEqu, tyds)  => foldl typdesc res tyds
58	  | TYPEspec tybs               => foldl typbind res tybs
59	  | DATATYPEspec (dbs, tybsOpt) =>
60		foldl datbind (foldl typbind res (getOpt(tybsOpt, []))) dbs
61	  | DATATYPErepspec (ty, _)     => datrep (ty, res)
62	  | EXCEPTIONspec eds           => foldl exdesc res eds
63	  | LOCALspec (spec1, spec2)    => processSpec is str (spec2, res)
64	  | OPENspec strs               => res
65	  | EMPTYspec                   => res
66	  | SEQspec (spec1, spec2)      =>
67		processSpec is str (spec2, processSpec is str (spec1, res))
68	  | STRUCTUREspec moddescs      => res (* TODO: add link *)
69    end
70
71fun parseAndProcess dir str res =
72    let val filename = Path.joinDirFile
73	    {dir=dir, file = Path.joinBaseExt{base = str, ext = SOME "sig"}}
74	val _ = print("Parsing " ^ filename ^ " ... ");
75	val resLength = length res
76	val is           = open_in filename
77	val lexbuf       = createLexerStream is
78	val specs        = case parseSpec lexbuf of
79	                        Asynt.NamedSig {specs, ...} => specs
80			      | Asynt.AnonSig specs         => specs;
81	val initialbase = {comp = Database.Str, file = str, line = 0} :: res
82	val res = foldl (processSpec is str) initialbase specs
83	val _ = print ("processed " ^ Int.toString (length res - resLength)
84		       ^ " entries.\n")
85    in
86	close_in is; res
87    end
88    handle exn as Parsing.ParseError _ =>
89	(print ("Parseerror in signature " ^ str ^ ".\n"); raise exn)
90
91(* To parse the signature of unit `filename' and prepend the
92 * entries to the list res:
93 *)
94
95fun processfile stoplist dir (filename, res) =
96    let val {base, ext} = Path.splitBaseExt filename
97    in
98	case ext of
99	    SOME "sig" =>
100		if List.exists (fn name => base = name) stoplist then
101		    res
102		else
103		    parseAndProcess dir base res
104	  | _          => res
105    end
106