1(*
2    Copyright (c) 2000
3        Cambridge University Technical Services Limited
4
5    This library is free software; you can redistribute it and/or
6    modify it under the terms of the GNU Lesser General Public
7    License as published by the Free Software Foundation; either
8    version 2.1 of the License, or (at your option) any later version.
9    
10    This library is distributed in the hope that it will be useful,
11    but WITHOUT ANY WARRANTY; without even the implied warranty of
12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13    Lesser General Public License for more details.
14    
15    You should have received a copy of the GNU Lesser General Public
16    License along with this library; if not, write to the Free Software
17    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
18*)
19
20(*
21    Title:  Parse Types.
22    Author:     Dave Matthews, Cambridge University Computer Laboratory
23    Copyright   Cambridge University 1985
24*)
25
26functor PARSE_TYPE (
27
28structure SYMBOLS : SymbolsSig
29structure SYMSET : SymsetSig
30structure LEX : LEXSIG
31
32structure SKIPS :
33sig
34  type sys;
35  type lexan;
36  type symset;
37  type location =
38        { file: string, startLine: FixedInt.int, startPosition: FixedInt.int,
39          endLine: FixedInt.int, endPosition: FixedInt.int }
40  
41  val badsyms:  sys * lexan -> unit;
42  val getsym:   sys * lexan -> unit;
43  val skipon:   symset * symset * string * lexan -> unit;
44  val getid:    symset * symset * lexan -> string * location;
45  val getLabel: symset * lexan -> string * location;
46  val getList:  sys * symset * lexan * (unit -> 'a * location) -> 'a list * location;
47end;
48
49structure UTILITIES :
50sig
51    val noDuplicates: (string * 'a * 'a -> unit) -> 
52                       { apply: (string * 'a -> unit) -> unit,
53                         enter:  string * 'a -> unit,
54                         lookup: string -> 'a option };
55end
56
57structure TYPETREE : TYPETREESIG
58
59(*****************************************************************************)
60(*                  PARSETYPE sharing constraints                            *)
61(*****************************************************************************)
62
63sharing type
64  SYMBOLS.sys
65= SYMSET.sys
66= SKIPS.sys
67= LEX.sys
68
69sharing type
70  SYMSET.symset
71= SKIPS.symset
72
73sharing type
74  LEX.lexan
75= SKIPS.lexan
76                  
77) : 
78                  
79(*****************************************************************************)
80(*                  PARSETYPE export signature                               *)
81(*****************************************************************************)
82sig
83    type symset;
84    type lexan;
85    type types;
86    type typeParsetree;
87    type typeVarForm
88    type location =
89        { file: string, startLine: FixedInt.int, startPosition: FixedInt.int,
90          endLine: FixedInt.int, endPosition: FixedInt.int }
91     
92    val parseType: symset * lexan * {lookupTvar:string -> typeVarForm} -> typeParsetree * location;
93end =
94     
95
96(*****************************************************************************)
97(*                  PARSETYPE functor body                                   *)
98(*****************************************************************************)
99struct
100    open TYPETREE
101    open LEX
102    open SYMSET
103    open SKIPS
104    open SYMBOLS  
105    open UTILITIES
106   
107    infix 8 ++;
108    infix 8 inside;
109    
110    val tyseqSyntax = SYMSET.comma ++ SYMSET.rightParen
111    val lrSyntax    = SYMSET.comma ++ SYMSET.rightCurly
112   
113    fun parseType (fsys, lex, env) =
114    let
115        fun tupleType fsys =
116        let
117            fun basicType fsys =
118            let (* First part may be a type sequence. *)
119                val sym = sy lex and startLocn = location lex
120                val (tySeq, seqLocn) =
121                    case sym of
122                        LeftParen => (* sequence of types *)
123                        let
124                            fun processList () =
125                            let
126                                val thisType = 
127                                    if sy lex inside startTypeSys
128                                    then #1 (parseType (fsys ++ tyseqSyntax, lex, env))
129                                    else
130                                    (
131                                        badsyms (TypeIdent, lex);
132                                        ParseTypeBad (* not there *)
133                                    );
134                                fun testfor (sym, startsys, lex) =
135                                  (* repeat if the separator or a starting sym is found *)
136                                  if sy lex = sym
137                                    then (insymbol lex; true)
138                                  else if sy lex inside startsys
139                                    then (badsyms (sym, lex); true)
140                                  else false;
141
142                            in (* Check for any more *)
143                                if testfor (SYMBOLS.Comma, startTypeSys, lex)
144                                then thisType :: processList() (* get some more *)
145                                else [thisType] (* that's it *)
146                            end (* processList *);
147
148                            val ()      = insymbol lex;  (* Remove opening bracket *)
149                            val sequence = processList(); (* read list of items *)
150                            val endLocn = location lex (* Should be the loc. of the close paren. *)
151                        in
152                            getsym (SYMBOLS.RightParen, lex);
153                            (sequence, locSpan(startLocn, endLocn))
154                        end
155
156                    |   LeftCurly =>
157                        let
158                            val () = insymbol lex; (* Remove opening bracket *)
159                            val posEnd = location lex
160                        in
161                            case sy lex of
162                                RightCurly =>
163                                let
164                                    val () = insymbol lex
165                                    val locs = locSpan(startLocn, posEnd)
166                                in
167                                    ([unitTree locs], locs)
168                                end
169        
170                            |   _ =>
171                                let
172                                    (* The same label name should not be used more than once. *)
173                                    fun reportDup (name, newLoc, _) =
174                                        errorMessage (lex, newLoc, "Label (" ^ name ^ ") appears more than once.")
175                                    val dupCheck = noDuplicates reportDup
176                                    (* All the labels should be the same sort. *)
177                                    val (l, _) = 
178                                        getList (SYMBOLS.Comma, empty, lex,
179                                            fn () =>
180                                            let
181                                                val nameAndLoc as (_, nameLoc) =
182                                                    getLabel (fsys ++ SYMSET.colon, lex);
183                                                val () = #enter dupCheck nameAndLoc;
184                                                val () = getsym (SYMBOLS.Colon, lex);
185                                                val (types, typeLoc) = parseType (fsys ++ lrSyntax, lex, env)
186                                                val fullLoc = locSpan(nameLoc, typeLoc)
187                                            in
188                                                ((nameAndLoc, types, fullLoc), fullLoc)
189                                            end);
190                                    val locs = locSpan(startLocn, location lex) (* Include '}' *)
191                                in
192                                    getsym (SYMBOLS.RightCurly, lex);
193                                    ([makeParseTypeLabelled(l, true, locs) (* frozen *)], locs)
194                                end
195                        end
196                    
197                    |   TypeIdent =>
198                        let (* type variable *)
199                            val ty = #lookupTvar env (id lex);
200                        in
201                            getsym (TypeIdent, lex);
202                            ([makeParseTypeId(ty, startLocn)], startLocn)
203                        end
204      
205                    |   Ident =>
206                        (* Constructor such as `int' *)
207                        let
208                            val idLocn as (_, locn) = getid (SYMSET.ident, fsys, lex)
209                        in
210                            ([makeParseTypeConstruction (idLocn, ([], locn), locn)], locn)
211                        end
212
213                    |   _ =>
214                        (
215                            badsyms (SYMBOLS.Ident, lex);
216                            ([], startLocn)
217                        )
218            in
219                (* Type sequence read. Can now have some type constructors. *)
220                case (sy lex, tySeq) of
221                    (Ident, _) =>
222                    let (* Returns the type made from the constructors. *)
223                        fun constructors(args, argLoc) =
224                        let
225                            val idAndLoc as (_, idLoc) = (id lex, location lex)
226                            val loc = locSpan(argLoc, idLoc)
227                            val constructed = makeParseTypeConstruction(idAndLoc, (args, argLoc), loc);
228                        in
229                            insymbol lex;
230                            if sy lex = SYMBOLS.Ident
231                            then constructors([constructed], loc)
232                            else (constructed, loc)
233                        end;
234                    in
235                        constructors(tySeq, seqLocn)
236                    end
237
238                (* no constructor - get the first part of the sequence
239                   and check that that's all. *)
240                |   (_, [])   =>    (ParseTypeBad, seqLocn)
241                |   (_, [t])  => (t, seqLocn)
242                |   (_, t::_) => (badsyms (SYMBOLS.Ident, lex); (t, seqLocn))
243            end (* basicType *);
244
245            (* ty * .. * ty  *)
246            fun getProduct () =
247            let
248                val fsys' = fsys ++ SYMSET.asterisk;
249                val (firstPart, firstLocn) = basicType fsys'
250            in
251                case sy lex of
252                    Asterisk =>
253                    let
254                        val () = insymbol lex
255                        val (rest, restLocn) = getProduct ()
256                    in
257                        (firstPart :: rest, locSpan(firstLocn, restLocn))
258                    end
259                |   _ => ([firstPart], firstLocn)
260            end
261        in
262            case getProduct () of
263                ([notProduct], locn) => (notProduct, locn)
264            |   (product, locn) => (makeParseTypeProduct(product, locn), locn)
265        end  (* tupleType *)(* ty -> ty *)
266   
267        val (firstType, firstLoc) = tupleType (fsys ++ SYMSET.arrow);
268    in
269        case sy lex of
270            Arrow =>
271            let
272                val () = insymbol lex
273                val (resType, resLocn) = parseType (fsys, lex, env)
274                val locs = locSpan(firstLoc, resLocn)
275            in
276                (makeParseTypeFunction (firstType, resType, locs), locs)
277            end
278        |   _ =>
279            (
280                skipon (fsys, empty, "End of type", lex);
281                (firstType, firstLoc)
282            )
283    end
284end;
285