Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /smlnj-lib/trunk/Dev/XML/xml-parser-fn.sml
ViewVC logotype

Diff of /smlnj-lib/trunk/Dev/XML/xml-parser-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 3867, Wed Dec 18 19:39:08 2013 UTC revision 3868, Wed Dec 18 21:18:28 2013 UTC
# Line 9  Line 9 
9    
10      structure XMLTree : XML_TREE      structure XMLTree : XML_TREE
11    
12      fun parseFile : string -> XMLTree.file      val parseFile : string -> XMLTree.file
13    
14        exception ParseError of string
15    
16    end    end
17    
# Line 19  Line 21 
21      structure XMLTree = XT      structure XMLTree = XT
22      structure XS = XT.Schema      structure XS = XT.Schema
23    
24      datatype content = XT.content      datatype token = datatype XMLTokens.token
25    
26      (***** Error messages *****)
27    
28        exception ParseError of string
29    
30        datatype error_tag
31          = S of string
32          | ID of string
33          | TK of token
34          | E of XT.Schema.element
35    
36        fun error msg = let
37              fun cvt (S s, l) = s :: l
38                | cvt (ID id) = "\"" :: id :: "\"" :: l
39                | cvt (TK tok) = XMLTokens.toString tok :: l
40                | cvt (E elem) = XS.toString elem :: l
41              in
42                raise ParseError(String.concat(List.foldr cvt [] msg))
43              end
44    
45      (***** Token streams wrap the ML-ULex generated lexer *****
46       *
47       * We cache tokens to avoid rescanning the source.
48       *)
49    
50        type lexer_state = XMLLexer.prestrm * XMLLexer.yystart_state
51    
52        datatype token_strm_rep
53          = TOK of {tok : token, span : XMLLexer.span, more : token_strm}
54          | MORE of {
55              state : lexer_state,
56              get : lexer_state -> token * XMLLexer.span * lexer_state
57            }
58    
59        withtype token_strm = token_strm_rep ref
60    
61        fun newTokenStrm (initialState, lexFn) =
62              ref(MORE{state = initialState, get=lexFn})
63    
64        fun nextTok (ref(TOK{tok, span, more})) = (tok, span, more)
65          | nextTok (strm as ref(MORE{state, get})) = let
66              val (tok, span, state) = get state
67              val more = ref(MORE{state=state, get=lexFn})
68              val rep = TOK{tok=tok, span=span, more=more}
69              in
70                strm := rep; (* cache lexer result *)
71                (tok, more)
72              end
73    
74        datatype content = datatype XT.content
75    
76      (***** Stack of open elements *****)
77    
78      type stack = (element * attribute list) list      type stack = (element * attribute list) list
79    
80      (****** Parser state *****)
81    
82      type state = {      type state = {
83          stk : stack,            (* stack of currently open elements *)          stk : stack,            (* stack of currently open elements *)
84          content : content list, (* parse content in reverse order *)          content : content list, (* parsed content in reverse order *)
85          preWS : string option   (* preceeding WS when we are not preserving whitespace *)          preWS : string option   (* preceeding WS when we are not preserving whitespace *)
86        }        }
87    
# Line 33  Line 89 
89        | mergeWS (SOME ws, XT.TEXT txt :: content) = XT.TEXT(txt ^ ws) :: content        | mergeWS (SOME ws, XT.TEXT txt :: content) = XT.TEXT(txt ^ ws) :: content
90        | mergeWS (SOME s, content) = XT.TEXT s :: content        | mergeWS (SOME s, content) = XT.TEXT s :: content
91    
92      fun add ({stk, content, preWS}, name, ) =      fun add ({stk, content, preWS}, name, elem) =
93            {stk = stk, content = XT.ELEMENT elem :: mergeWS (preWS, content), preWS = NONE}            {stk = stk, content = XT.ELEMENT elem :: mergeWS (preWS, content), preWS = NONE}
94    
95      fun addWS ({stk, content, preWS}, ws) = (case preWS      fun addWS ({stk, content, preWS}, ws) = (case preWS
# Line 55  Line 111 
111      fun addCData ({stk, content, preWS}, cdata) =      fun addCData ({stk, content, preWS}, cdata) =
112            {stk = stk, content = XT.CDATA cdata :: mergeWS (preWS, content), preWS = NONE}            {stk = stk, content = XT.CDATA cdata :: mergeWS (preWS, content), preWS = NONE}
113    
114      (***** Parsing *****)
115    
116        fun parser (name, inStrm) = let
117              val srcMap = AntlrStreamPos.mkSourcemap' name
118              fun err (span, msg) =
119                    error(S "Error [" :: S(AntlrStreamPos.spanToString srcMap span) :: S "]: " :: msg)
120            (* scan an element identifier *)
121              fun getElementId tokStrm = (case nextTok tokStrm
122                     of (ID id, tokStrm) => (case XS.element id
123                           of SOME elem => (elem, tokStrm)
124                            | NONE => err(span, [S "unrecognized element ", S id])
125                          (* end case *))
126                      | (tok, span, _) => err(span, [S "expected identifier, but found ", TK tok])
127                    (* end case *))
128            (* parse the content of an element *)
129      fun parseContent (tokStrm, state) = (case nextTok tokStrm      fun parseContent (tokStrm, state) = (case nextTok tokStrm
130             of (T.EOF, _) => if List.null stk                   of (EOF, span, _) => (case (#stk state)
131                  then List.rev content                         of [] => List.rev content
132                  else (* error: missing close tags *)                          | (elem, _)::_ => err(span, [S "missing close ", E elem])
133              | (T.OPEN_START_TAG, tokStrm) => parseStartTag (tokStrm, state)                        (* end case *))
134              | (T.OPEN_END_TAG , tokStrm)=> parseEndTag (tokStrm, state)                    | (OPEN_START_TAG, _, tokStrm) => parseStartTag (tokStrm, state)
135              | (T.OPEN_XML_TAG, tokStrm) => parseXMLDecl (tokStrm, state)                    | (OPEN_END_TAG, _, tokStrm)=> parseEndTag (tokStrm, state)
136              | (T.WS s, tokStrm) => parseContent (tokStrm, addWS(state, s))                    | (WS s, _, tokStrm) => parseContent (tokStrm, addWS(state, s))
137              | (T.TEXT s, tokStrm) => parseContent (tokStrm, addText(state, s))                    | (TEXT s, _, tokStrm) => parseContent (tokStrm, addText(state, s))
138              | (T.CDATA s, tokStrm) => parseContent (tokStrm, addCData(state, s))                    | (COM s, _, tokStrm) => parseContent (tokStrm, addCom(state, s))
139              | (tok, _) => raise Fail"impossible: unexpected ", Token.toString tok)                    | (CDATA s, _, tokStrm) => parseContent (tokStrm, addCData(state, s))
140            (* end case *))                    | (tok, span, _) => err(span, [S "impossible: unexpected ", TK tok])
141                    (* end case *))
142    (* parse ID Attributes (">" | "/>") *)          (* expect: ID Attributes (">" | "/>") *)
143      and parseStartTag (tokStrm, state) = (case nextTok tokStrm            and parseStartTag (tokStrm, state) = let
144             of (T.ID id, tokStrm) => (case XS.element id                  val (elem, tokStrm) = getElementId tokStrm
                  of SOME elem => let  
145                        val (attrs, tokStrm) = parsAttributes tokStrm                        val (attrs, tokStrm) = parsAttributes tokStrm
146                        in                        in
147                          case (nextTok tokStrm                    case (nextTok tokStrm)
148                           of (T.CLOSE_TAG, tokStrm) =>                     of (CLOSE_TAG, _, tokStrm) =>
149                                parseContent (tokStrm, push(state, elem, attrs))                                parseContent (tokStrm, push(state, elem, attrs))
150                            | (T.CLOSE_EMPTY_TAG, tokStrm) =>                      | (CLOSE_EMPTY_TAG, _, tokStrm) =>
151                                endElement (tokStrm,                                endElement (tokStrm,
152                                  add(state, XT.ELEMENT{name=elem, attrs=attrs, content=[]}))                                  add(state, XT.ELEMENT{name=elem, attrs=attrs, content=[]}))
153                            | (tok, _) => (* error *)                      | (tok, span, _) => err(span, [S "expected \">\" or \"/>\", but found ", TK tok])
154                          (* end case *)                          (* end case *)
155                        end                        end
156                    | NONE => (* error: unrecognized element *)          (* expect: ID ">" *)
157                  (* end case *))            and parseEndTag (tokStrm, state) = let
158              | (tok, _) => (* error: unrecognized element *)                  val (elem, tokStrm) = getElementId tokStrm
           (* end case *))  
   
   (* parse ID ">" *)  
     and parseEndTag (tokStrm, state) = (case nextTok tokStrm  
            of (T.ID id, tokStrm) => (case XS.element id  
                  of SOME elem => let  
159                        val (content, attrs, state) = pop (state, elem)                        val (content, attrs, state) = pop (state, elem)
160                        in                        in
161                          endElement (tokStrm,                          endElement (tokStrm,
162                            add(state, XT.ELEMENT{name=elem, attrs=attrs, content=content}))                            add(state, XT.ELEMENT{name=elem, attrs=attrs, content=content}))
163                        end                        end
                   | NONE => (* error: unrecognized element *)  
                 (* end case *))  
             | (tok, _) => (* error: unrecognized element *)  
           (* end case *))  
   
164    (* handle an end tag or empty element tag *)    (* handle an end tag or empty element tag *)
165      and endElement (tokStrm, state) = if emptyStack state      and endElement (tokStrm, state) = if emptyStack state
166            then state            then state
167            else parseContent (tokStrm, state)            else parseContent (tokStrm, state)
168            (* expect: (ID "=" LIT)* *)
   (* parse (ID "=" LIT)* *)  
169      and parseAttributes (tokStrm, state) = let      and parseAttributes (tokStrm, state) = let
170            fun parseAttr (tokStrm, attrs) = (case nextTok tokStrm            fun parseAttr (tokStrm, attrs) = (case nextTok tokStrm
171                   of (T.ID id, tokStrm) => (case nextTok tokStrm                         of (ID id, _, tokStrm) => (case nextTok tokStrm
172                         of (T.SYM_EQ, tokStrm) => (case nextTok tokStrm                               of (SYM_EQ, tokStrm) => (case nextTok tokStrm
173                               of (T.LIT v, tokStrm) =>                                     of (LIT v, _, tokStrm) =>
174                                    parseAttr (tokStrm, XS.attribute(id, v)::attrs)                                    parseAttr (tokStrm, XS.attribute(id, v)::attrs)
175                                | (tok, _) => (* error: expected value *)                                      | (tok, span, _) => err(span, [S "expected attribute value, but found ", TK tok])
176                              (* end case *))                              (* end case *))
177                          | (tok, _) => (* expected "=" *)                                | (tok, span, _) => err(span, [S "expected \"=\", but found ", TK tok])
178                        (* end case *))                        (* end case *))
179                    | _ => (tokStrm, List.rev attrs)                    | _ => (tokStrm, List.rev attrs)
180                  (* end case *))                  (* end case *))
             |  
181            in            in
182              parseAttr (tokStrm, [])              parseAttr (tokStrm, [])
183                    end
184    (* parse Attributes "?>" *)          (* expect: Attributes "?>" *)
185      and parseXMLDecl (tokStrm, state) = let      and parseXMLDecl (tokStrm, state) = let
186            val (attrs, tokStrm) = parseAttributes (tokStrm, state)            val (attrs, tokStrm) = parseAttributes (tokStrm, state)
187            in            in
188              case nextTok tokStrm              case nextTok tokStrm
189               of (T.CLOSE_XML_TAG, tokStrm) => (attrs, tokStrm)                     of (CLOSE_XML_TAG, _, tokStrm) => (attrs, tokStrm)
190                | (tok, _) => (* error: unrecognized element *)                      | (tok, span, _) => err(span, [S "expected \"?>\", but found ", TK tok])
191              (* end case *)              (* end case *)
192            end            end
193            (* expect: ID (S ExternalID)? S? '>'
194             * where
195             *      ExternalID ::= 'SYSTEM' LIT
196             *                  |  'PUBLIC' LIT LIT
197             *)
198              fun parseDoctype (tokStrm, state) = raise Fail "FIXME"
199            (* initialize the token stream *)
200              val tokStrm = newTokenStrm (
201                    XMLLexer.streamifyInstream inStrm,
202                    XMLLexer.lex srcMap (fn (pos, msg) => err((pos, pos), msg)))
203            (* parse the XML Decl (if any) *)
204              val (xmlDecl, tokStrm) = let
205                    fun getXMLDecl tokStrm = (case nextTok tokStrm
206                           of (OPEN_XML_TAG, _, tokStrm) => parseXMLDecl tokStrm
207                            | (WS _, _, tokStrm) => getXMLDecl tokStrm
208                            | (COM _, _, tokStrm) => getXMLDecl tokStrm
209                            | _ => (NONE, tokStrm)
210                          (* end case *))
211                    in
212                      getXMLDecl tokStrm
213                    end
214            (* initial parser state *)
215              val state = initialState()
216              in
217    raise Fail "FIXME"
218              end (* parser *)
219    
220    (*
221    (* parse XMLDecl? Content *)    (* parse XMLDecl? Content *)
222      and parseFile tokStrm = let            and parse tokStrm = let
           val state = initialState()  
           val (xmlDecl, tokStrm) = (case nextTok tokStrm  
                  of (T.OPEN_XML_TAG, tokStrm) => parseXMLDecl tokStrm  
                   | _ => ([], tokStrm)  
                 (* end case *))  
223            fun parse tokStrm = (case nextTok tokStrm            fun parse tokStrm = (case nextTok tokStrm
224                   of (T.EOF, _) => {xmlDecl = xmlDecl, content = TEXT ""}                         of (EOF, _) => {xmlDecl = xmlDecl, content = TEXT ""}
225                    | (T.OPEN_START_TAG, tokStrm) => let                          | (OPEN_START_TAG, tokStrm) => let
226                        val finalState = parseStartTag (tokStrm, content, stk)                        val finalState = parseStartTag (tokStrm, content, stk)
227                        in                        in
228                          {xmlDecl = xmlDecl, content = ??}                          {xmlDecl = xmlDecl, content = ??}
229                        end                        end
230                    | T.WS _ => parse tokStrm                          | WS _ => parse tokStrm
231                    | tok, _) => raise Fail"impossible: unexpected ", Token.toString tok)                          | tok, _) => err(?, [S "impossible: unexpected ", TK tok])
232                  (* end case *))                  (* end case *))
233            in            in
234              parse tokStrm before close tokStrm              parse tokStrm before close tokStrm
235            end            end
236    *)
237    
238        fun parseFile file = let
239              val inStrm = TextIO.openIn file
240              val tree = parser (file, inStrm)
241                    handle ex => (TextIO.closeIn inStrm; raise ex)
242              in
243                TextIO.closeIn inStrm;
244                tree
245              end
246    
247    end    end

Legend:
Removed from v.3867  
changed lines
  Added in v.3868

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0