I forgot the mercurial patch. Here I add it.
# HG changeset patch # User Gabriel Riba Faura <[email protected]> # Date 1435587471 -7200 # Node ID a756ac914b6a50443796972d0fbfcd8090b2839b # Parent 7ce804ecd56bdcffc841d9bfab8ecc57a809d2e6 indented xml with lines first tag autoclosing and logic diff -r 7ce804ecd56b -r a756ac914b6a lib/ur/top.ur --- a/lib/ur/top.ur Thu Jun 11 19:38:03 2015 -0400 +++ b/lib/ur/top.ur Mon Jun 29 16:17:51 2015 +0200 @@ -413,3 +413,25 @@ fun assert [a] (cond: bool) (msg: string) (loc: string) (x:a): a = if cond then x else error <xml>{txt msg} at {txt loc}</xml> + +fun ixml_foldlmapx [a] [ctx ::: {Unit}] (f: a -> xml ctx [] []) (li: list a): xml ctx [] [] = + let foldlmapx' li <xml/> + where fun foldlmapx' (li': list a) (acc: xml ctx [] []) = + case li' of + | x :: tl => foldlmapx' tl <xml>{acc}{f x}</xml> + | _ => acc + end + +fun ixml_foldrmapx [a] [ctx ::: {Unit}] (f: a -> xml ctx [] []) (li: list a): xml ctx [] [] = + let foldrmapx' li <xml/> + where fun foldrmapx' (li': list a) (acc: xml ctx [] []) = + case li' of + | x :: tl => foldrmapx' tl <xml>{f x}{acc}</xml> + | _ => acc + end + +fun ixml_alternatives [ctx ::: {Unit}] (li: list (bool * xml ctx [] [])): xml ctx [] [] = + case li of + (cond, xml_exp) :: rest => if cond then xml_exp + else ixml_alternatives rest + | [] => error <xml>ixml_alternatives: unexpected end of list</xml> diff -r 7ce804ecd56b -r a756ac914b6a lib/ur/top.urs --- a/lib/ur/top.urs Thu Jun 11 19:38:03 2015 -0400 +++ b/lib/ur/top.urs Mon Jun 29 16:17:51 2015 +0200 @@ -297,3 +297,8 @@ -> string (* Source location of the bad thing *) -> t (* Return this value if all went well. *) -> t + +val ixml_foldlmapx: a ::: Type -> ctx ::: {Unit} -> (a -> xml ctx [] []) -> list a -> xml ctx [] [] +val ixml_foldrmapx: a ::: Type -> ctx ::: {Unit} -> (a -> xml ctx [] []) -> list a -> xml ctx [] [] + +val ixml_alternatives: ctx ::: {Unit} -> list (bool * xml ctx [] []) -> xml ctx [] [] diff -r 7ce804ecd56b -r a756ac914b6a src/urweb.grm --- a/src/urweb.grm Thu Jun 11 19:38:03 2015 -0400 +++ b/src/urweb.grm Mon Jun 29 16:17:51 2015 +0200 @@ -366,6 +366,29 @@ | _ => (ErrorMsg.errorAt (#2 e) "This is an expression but not a pattern."; (PWild, #2 e)) +val ixml_ifThenElsifElse: (exp * exp * (exp * exp) list * exp * ErrorMsg.span) -> exp = + fn (if_cond, if_case, pairListElsif, else_case, loc) => + let + (* build alternatives as (cond * expr) list *) + val eNil = (EVar (["Basis"], "Nil", Infer), loc) + val eTrue = (EVar (["Basis"], "True", Infer), loc) + fun pair v1 v2 = (ERecord ([((CName "1", loc), v1), + ((CName "2", loc), v2)], false), loc) + fun cons x rest = let val v = (EVar (["Basis"], "Cons", Infer), loc) + val r = pair x rest + in + (EApp( v, r), loc) + end + val pairIf = pair if_cond if_case + val pairElse = pair eTrue else_case + fun consWithAcc acc li = + case li of + (cond, xml) :: rest => consWithAcc (cons (pair cond xml) acc) rest + | [] => acc + in + cons pairIf (consWithAcc (cons pairElse eNil) (rev pairListElsif)) + end + %% %header (functor UrwebLrValsFn(structure Token : TOKEN)) @@ -405,6 +428,9 @@ | CIF | CTHEN | CELSE | FWDAPP | REVAPP | COMPOSE | ANDTHEN | BACKTICK_PATH of string + | IXML_FOLDRMAP | IXML_END_FOLDRMAP | IXML_FOLDLMAP | IXML_END_FOLDLMAP + | IXML_IFTHEN | IXML_END_IFTHEN | IXML_ELSE | IXML_END_ELSE | IXML_ELSIF | IXML_END_ELSIF + | IXML_CASE_EXPR | IXML_END_CASE_EXPR | IXML_CASE_OF | IXML_END_CASE_OF %nonterm file of decl list @@ -478,6 +504,12 @@ | xml of exp | xmlOne of exp | xmlOpt of exp + + | ixml_elsif of (exp * exp) + | ixml_elsifs of (exp * exp) list + | ixml_caseOf of pat * exp + | ixml_caseOfs of (pat * exp) list + | tag of (string * exp) * exp option * exp option * exp | tagHead of string * exp | bind of pat * con option * exp @@ -1659,6 +1691,50 @@ (EApp (e, eexp), loc) end) + | IXML_FOLDRMAP LBRACE eexp RBRACE FWDAPP LBRACE eargs RBRACE xml IXML_END_FOLDRMAP (let + val loc = s (IXML_FOLDRMAPleft, IXML_END_FOLDRMAPright) + val fn_args_to_xml = #1 (eargs (xml, (CWild (KType, loc), loc))) + val ixml_foldrmapx = (EVar (["Top"], "ixml_foldrmapx", Infer), loc) + val e = (EApp (ixml_foldrmapx, fn_args_to_xml), loc) + in + (EApp (e, eexp), loc) + end + ) + + | IXML_FOLDLMAP LBRACE eexp RBRACE FWDAPP LBRACE eargs RBRACE xml IXML_END_FOLDLMAP (let + val loc = s (IXML_FOLDLMAPleft, IXML_END_FOLDLMAPright) + val fn_args_to_xml = #1 (eargs (xml, (CWild (KType, loc), loc))) + val ixml_foldlmapx = (EVar (["Top"], "ixml_foldlmapx", Infer), loc) + val e = (EApp (ixml_foldlmapx, fn_args_to_xml), loc) + in + (EApp (e, eexp), loc) + end + ) + + | IXML_IFTHEN LBRACE eexp RBRACE xml IXML_END_IFTHEN ixml_elsifs IXML_ELSE xmlOpt IXML_END_ELSE + (let + val loc = s (IXML_IFTHENleft, IXML_END_ELSEright) + val alternativeList = ixml_ifThenElsifElse (eexp, xml, ixml_elsifs, xmlOpt, loc) + val f = (EVar (["Top"], "ixml_alternatives", Infer), loc) + in + (EApp (f, alternativeList), loc) + end) + + | IXML_CASE_EXPR LBRACE eexp RBRACE IXML_END_CASE_EXPR ixml_caseOfs + (ECase (eexp, ixml_caseOfs), s (IXML_CASE_EXPRleft, ixml_caseOfsright)) + +ixml_elsif : IXML_ELSIF LBRACE eexp RBRACE xml IXML_END_ELSIF ((eexp, xml)) + +ixml_elsifs : ((* empty *) []) + | ixml_elsifs ixml_elsif (ixml_elsifs @ [ixml_elsif]) + + +ixml_caseOf : IXML_CASE_OF LBRACE pat RBRACE xml IXML_END_CASE_OF ((pat, xml)) + +ixml_caseOfs : ixml_caseOf ((* one or more *) [ixml_caseOf]) + | ixml_caseOfs ixml_caseOf (ixml_caseOfs @ [ixml_caseOf]) + + tag : tagHead attrs (let val pos = s (tagHeadleft, attrsright) diff -r 7ce804ecd56b -r a756ac914b6a src/urweb.lex --- a/src/urweb.lex Thu Jun 11 19:38:03 2015 -0400 +++ b/src/urweb.lex Mon Jun 29 16:17:51 2015 +0200 @@ -93,9 +93,49 @@ end val xmlTag = ref ([] : string list) -val xmlString = ref true + +datatype xmlStringContext = SC_XMLTAG | SC_IXMLTAG + +val xmlString = ref (NONE : xmlStringContext option) + val braceLevels = ref ([] : ((unit -> unit) * int) list) +val isIXML = ref false +val ixml_candidate_tag_to_push = ref (NONE: (int * string) option) + +datatype ixml_logic = IXL_FoldrMap | IXL_FoldlMap + | IXL_IfThen | IXL_Else | IXL_Elsif + | IXL_CaseExpr | IXL_CaseOf + + +datatype ixml_item = IX_Tag of string | IX_Logic of ixml_logic + +val ixml_indents = ref ([] : (int * ixml_item) list) + +val ixml_pop_deeper_or_same_level_items: int -> ixml_item option = fn indent => + case !ixml_indents of + [] => NONE + | (lastIndent, item) :: _ => if lastIndent >= indent then + (ixml_indents := tl (!ixml_indents) ; SOME item) + else NONE + +val ixml_emit_item_closing_and_rewind: (ixml_item * int ref * string * int) -> (svalue,pos) Tokens.token = + fn (item, yybufpos, yytext, yypos) => + ((* rewind yybufpos *) yybufpos := (!yybufpos) - size yytext ; + case item of + (IX_Tag tag_to_close) => Tokens.END_TAG (tag_to_close, yypos, yypos + size yytext) + | (IX_Logic ixl) => (case ixl of + IXL_FoldrMap => Tokens.IXML_END_FOLDRMAP (yypos, yypos + size yytext) + | IXL_FoldlMap => Tokens.IXML_END_FOLDLMAP (yypos, yypos + size yytext) + | IXL_IfThen => Tokens.IXML_END_IFTHEN (yypos, yypos + size yytext) + | IXL_Else => Tokens.IXML_END_ELSE (yypos, yypos + size yytext) + | IXL_Elsif => Tokens.IXML_END_ELSIF (yypos, yypos + size yytext) + | IXL_CaseExpr => Tokens.IXML_END_CASE_EXPR (yypos, yypos + size yytext) + | IXL_CaseOf => Tokens.IXML_END_CASE_OF (yypos, yypos + size yytext) + ) + ) + + fun pushLevel s = braceLevels := (s, 1) :: (!braceLevels) fun enterBrace () = @@ -115,7 +155,7 @@ fun initialize () = (reset (); xmlTag := []; - xmlString := false) + xmlString := NONE) structure StringMap = BinaryMapFn(struct @@ -174,7 +214,7 @@ %% %header (functor UrwebLexFn(structure Tokens : Urweb_TOKENS)); %full -%s COMMENT STRING CHAR XML XMLTAG; +%s COMMENT STRING CHAR XML XMLTAG IXML IXMLTAG IXML_LOGIC; id = [a-z_][A-Za-z0-9_']*; xmlid = [A-Za-z][A-Za-z0-9_-]*; @@ -187,10 +227,12 @@ xcom = ([^\-]|(-[^\-]))+; oint = [0-9][0-9][0-9]; xint = x[0-9a-fA-F][0-9a-fA-F]; +indent = \n(\ )*; +spcs = (\ )*; %% -<INITIAL,COMMENT,XMLTAG> +<INITIAL,COMMENT,XMLTAG,IXMLTAG> \n => (newline yypos; continue ()); <XML> \n => (newline yypos; @@ -206,11 +248,21 @@ commentOut := (fn () => YYBEGIN XML); enterComment (pos yypos); continue ()); +<IXML> "(*" => (YYBEGIN COMMENT; + commentOut := (fn () => YYBEGIN IXML); + enterComment (pos yypos); + continue ()); <XMLTAG> "(*" => (YYBEGIN COMMENT; commentOut := (fn () => YYBEGIN XMLTAG); enterComment (pos yypos); continue ()); -<INITIAL,XML,XMLTAG> + +<IXMLTAG> "(*" => (YYBEGIN COMMENT; + commentOut := (fn () => YYBEGIN IXMLTAG); + enterComment (pos yypos); + continue ()); + +<INITIAL,XML,XMLTAG,IXML,IXMLTAG> "*)" => (ErrorMsg.errorAt' (pos yypos, pos yypos) "Unbalanced comments"; continue ()); @@ -219,7 +271,7 @@ <COMMENT> "*)" => (exitComment (); continue ()); -<XML> "<!--" {xcom} "-->" => (continue ()); +<XML,IXML> "<!--" {xcom} "-->" => (continue ()); <STRING,CHAR> "\\\"" => (str := #"\"" :: !str; continue()); <STRING,CHAR> "\\'" => (str := #"'" :: !str; continue()); @@ -268,10 +320,11 @@ val ch = String.sub (yytext, 0) in if ch = !strEnder then - (if !xmlString then - (xmlString := false; YYBEGIN XMLTAG) - else - YYBEGIN INITIAL; + ((case !xmlString of + SOME SC_XMLTAG => (xmlString := NONE; YYBEGIN XMLTAG) + | SOME SC_IXMLTAG => (xmlString := NONE; YYBEGIN IXMLTAG) + | NONE => YYBEGIN INITIAL + ); Tokens.STRING (String.implode (List.rev (!str)), !strStart, pos yypos + 1)) else (str := ch :: !str; @@ -286,9 +339,16 @@ <INITIAL> "<" {xmlid} ">"=> (let val tag = String.substring (yytext, 1, size yytext - 2) in - YYBEGIN XML; - xmlTag := tag :: (!xmlTag); - Tokens.XML_BEGIN (tag, yypos, yypos + size yytext) + if (!isIXML) then (ErrorMsg.errorAt' (yypos, yypos) "error: xml within ixml"; continue()) + else if tag = "ixml" then + (YYBEGIN IXML; isIXML := true; ixml_indents := [] ; + Tokens.XML_BEGIN ("xml", yypos, yypos + size yytext) + ) + else + (YYBEGIN XML; + xmlTag := tag :: (!xmlTag); + Tokens.XML_BEGIN (tag, yypos, yypos + size yytext) + ) end); <XML> "</" {xmlid} ">" => (let val id = String.substring (yytext, 2, size yytext - 3) @@ -309,7 +369,9 @@ Tokens.BEGIN_TAG (String.extract (yytext, 1, NONE), yypos, yypos + size yytext)); + <XMLTAG> "/" => (Tokens.DIVIDE (yypos, yypos + size yytext)); + <XMLTAG> ">" => (YYBEGIN XML; Tokens.GT (yypos, yypos + size yytext)); @@ -329,12 +391,13 @@ ("Expected float, received: " ^ yytext); continue ())); <XMLTAG> "\"" => (YYBEGIN STRING; - xmlString := true; strEnder := #"\""; + xmlString := SOME SC_XMLTAG; strEnder := #"\""; strStart := yypos; str := []; continue ()); <XMLTAG> "{" => (YYBEGIN INITIAL; pushLevel (fn () => YYBEGIN XMLTAG); Tokens.LBRACE (yypos, yypos + 1)); + <XMLTAG> "(" => (YYBEGIN INITIAL; pushLevel (fn () => YYBEGIN XMLTAG); Tokens.LPAREN (yypos, yypos + 1)); @@ -344,8 +407,8 @@ continue ()); <XML> "{" => (YYBEGIN INITIAL; - pushLevel (fn () => YYBEGIN XML); - Tokens.LBRACE (yypos, yypos + 1)); + pushLevel (fn () => YYBEGIN XML); + Tokens.LBRACE (yypos, yypos + 1)); <XML> {notags} => (Tokens.NOTAGS (unescape (yypos, yypos + size yytext) yytext, yypos, yypos + size yytext)); @@ -355,6 +418,180 @@ ("illegal XML character: \"" ^ yytext ^ "\""); continue ()); + + +<IXML> {indent} "<" {xmlid} => (let val toks = String.tokens (fn ch => ch = #"<") yytext + val tag = List.last toks + val indent = size (hd toks) -1 + in case ixml_pop_deeper_or_same_level_items indent of + + SOME item => ixml_emit_item_closing_and_rewind (item, yybufpos, yytext, yypos) + | NONE => (newline yypos; + ixml_candidate_tag_to_push := SOME (indent, tag) ; + YYBEGIN IXMLTAG; + Tokens.BEGIN_TAG (tag, yypos, yypos + size yytext) + ) + end) ; + +<IXML> "<" {xmlid} => (YYBEGIN IXMLTAG; + Tokens.BEGIN_TAG (String.extract (yytext, 1, NONE), + yypos, yypos + size yytext)); + +<IXML> {indent} "</ixml>" => (case ixml_pop_deeper_or_same_level_items 0 of + + SOME item => ixml_emit_item_closing_and_rewind (item, yybufpos, yytext, yypos) + | NONE => (newline yypos; + YYBEGIN INITIAL; + isIXML := false; + Tokens.XML_END (yypos, yypos + size yytext) + ) + ); + +<IXML> "</" {xmlid} ">" => (let + val id = String.substring (yytext, 2, size yytext - 3) + in + Tokens.END_TAG (id, yypos, yypos + size yytext) + end) ; + + + +<IXML> {indent} "{" => + (let val toks2 = String.tokens (fn ch => ch = #"{") yytext + val indent = size (hd toks2) -1 + in + case ixml_pop_deeper_or_same_level_items indent of + + SOME item => ixml_emit_item_closing_and_rewind (item, yybufpos, yytext, yypos) + | NONE => (newline yypos; + YYBEGIN INITIAL; + pushLevel (fn () => YYBEGIN IXML); + Tokens.LBRACE (yypos, yypos + 1) + ) + end); + +<IXML> {indent} "$" [a-z]+ => + (let val toks = String.tokens (fn ch => ch = #"$") yytext + val indent = size (hd toks) -1 + val sLogic = List.nth (toks, 1) + fun push_logic indent ixlogic = ixml_indents := (indent, IX_Logic ixlogic) :: (!ixml_indents) + in + case ixml_pop_deeper_or_same_level_items indent of + + SOME item => ixml_emit_item_closing_and_rewind (item, yybufpos, yytext, yypos) + | NONE => (newline yypos; + YYBEGIN IXML_LOGIC; + case sLogic of + "foldrmapx" => (push_logic indent IXL_FoldrMap ; + Tokens.IXML_FOLDRMAP (yypos, yypos + size yytext)) + + | "foldlmapx" => (push_logic indent IXL_FoldlMap ; + Tokens.IXML_FOLDLMAP (yypos, yypos + size yytext)) + + | "if" => (push_logic indent IXL_IfThen ; + Tokens.IXML_IFTHEN (yypos, yypos + size yytext)) + + | "elsif" => (push_logic indent IXL_Elsif ; + Tokens.IXML_ELSIF (yypos, yypos + size yytext)) + + | "else" => (push_logic indent IXL_Else ; + Tokens.IXML_ELSE (yypos, yypos + size yytext)) + + | "case" => (push_logic indent IXL_CaseExpr ; + Tokens.IXML_CASE_EXPR (yypos, yypos + size yytext)) + + | "of" => (push_logic indent IXL_CaseOf ; + Tokens.IXML_CASE_OF (yypos, yypos + size yytext)) + + | _ => (ErrorMsg.errorAt' (pos yypos, pos yypos + size yytext) + ("Unrecognized IXML logic:" ^ sLogic); + continue ()) + ) + end); + + +<IXML> {indent} [\$\t\v\f\r] . => ((* catch tabs and misplaced $ *) newline yypos; + ErrorMsg.errorAt' (pos yypos, pos yypos + size yytext) ("Unrecognized IXML:" ^ (String.extract (yytext, 1, NONE))); + continue ()); + +<IXML> {indent}(\\)? => ((* backslash enables to specify initial spacing *) newline yypos; continue()); + +<IXML> "#".* => ((* # end of line spaces delimiter, skip to EOL *) continue()); + +<IXML> "{" => (YYBEGIN INITIAL; + pushLevel (fn () => YYBEGIN IXML); + Tokens.LBRACE (yypos, yypos + 1)); + +<IXML> {notags} => (Tokens.NOTAGS (unescape (yypos, yypos + size yytext) yytext, yypos, yypos + size yytext)); + +<IXML> "(" => (Tokens.NOTAGS ("(", yypos, yypos + size yytext)); + +<IXML> . => (ErrorMsg.errorAt' (yypos, yypos) + ("illegal XML character: \"" ^ yytext ^ "\""); + continue ()); + +<IXMLTAG> "/" => (ixml_candidate_tag_to_push := NONE; + Tokens.DIVIDE (yypos, yypos + size yytext)); + +<IXMLTAG> ">" => (YYBEGIN IXML; + (case (!ixml_candidate_tag_to_push) of + SOME (indent, tag) => (ixml_indents := (indent, IX_Tag tag) :: (!ixml_indents) ; + ixml_candidate_tag_to_push := NONE) + | NONE => () + ); + Tokens.GT (yypos, yypos + size yytext)); + +<IXMLTAG> {ws}+ => (lex ()); + +<IXMLTAG> {xmlid} => (Tokens.SYMBOL (yytext, yypos, yypos + size yytext)); +<IXMLTAG> "=" => (Tokens.EQ (yypos, yypos + size yytext)); + +<IXMLTAG> {intconst} => (case Int64.fromString yytext of + SOME x => Tokens.INT (x, yypos, yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (yypos, yypos) + ("Expected int, received: " ^ yytext); + continue ())); +<IXMLTAG> {realconst} => (case Real.fromString yytext of + SOME x => Tokens.FLOAT (x, yypos, yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (yypos, yypos) + ("Expected float, received: " ^ yytext); + continue ())); +<IXMLTAG> "\"" => (YYBEGIN STRING; + xmlString := SOME SC_IXMLTAG; strEnder := #"\""; + strStart := yypos; str := []; continue ()); + +<IXMLTAG> "{" => (YYBEGIN INITIAL; + pushLevel (fn () => YYBEGIN IXMLTAG); + Tokens.LBRACE (yypos, yypos + 1)); +<IXMLTAG> "(" => (YYBEGIN INITIAL; + pushLevel (fn () => YYBEGIN IXMLTAG); + Tokens.LPAREN (yypos, yypos + 1)); + +<IXMLTAG> . => (ErrorMsg.errorAt' (yypos, yypos) + ("illegal XML tag character: \"" ^ yytext ^ "\""); + continue ()); +<IXML_LOGIC> {spcs} "{" => ( YYBEGIN INITIAL; + pushLevel (fn () => YYBEGIN IXML_LOGIC); + Tokens.LBRACE (yypos, yypos + size yytext) + ) ; + +<IXML_LOGIC> {spcs} "<|" => (Tokens.FWDAPP (pos yypos, pos yypos + size yytext)); + +<IXML_LOGIC> \n => ((* lookahead LF *) yybufpos := (!yybufpos) - size yytext ; + YYBEGIN IXML; + continue()); + +<IXML_LOGIC> [^{<\n\t\v\f]* => ((* skip to EOL except for tabs *) continue()); + +<IXML_LOGIC> . => (let val code = ord (String.sub (yytext, 0)) + val strCode = Int.toString code + in + ErrorMsg.errorAt' (yypos, yypos) + ("illegal IXML logic character code: " ^ strCode); + continue () + end); + + + <INITIAL> "()" => (Tokens.UNIT (pos yypos, pos yypos + size yytext)); <INITIAL> "(" => (Tokens.LPAREN (pos yypos, pos yypos + size yytext)); <INITIAL> ")" => (Tokens.RPAREN (pos yypos, pos yypos + size yytext));
_______________________________________________ Ur mailing list [email protected] http://www.impredicative.com/cgi-bin/mailman/listinfo/ur
