Mercurial > urweb
changeset 1:4202f6eda946
Initial parsing and pretty-printing
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 26 Jan 2008 12:35:32 -0500 |
| parents | 502c6d622477 |
| children | 64f09f7822c3 |
| files | .hgignore Makefile src/compiler.sig src/compiler.sml src/errormsg.sig src/errormsg.sml src/laconic.sml src/laconic_print.sig src/laconic_print.sml src/lacweb.grm src/lacweb.lex src/main.mlton.sml src/print.sig src/print.sml src/sources tests/stuff.lac |
| diffstat | 16 files changed, 796 insertions(+), 6 deletions(-) [+] |
line wrap: on
line diff
--- a/.hgignore Sat Jan 26 10:06:22 2008 -0500 +++ b/.hgignore Sat Jan 26 12:35:32 2008 -0500 @@ -8,3 +8,6 @@ src/lacweb.cm src/lacweb.mlb + +*.lex.* +*.grm.*
--- a/Makefile Sat Jan 26 10:06:22 2008 -0500 +++ b/Makefile Sat Jan 26 12:35:32 2008 -0500 @@ -37,5 +37,7 @@ MLTON += -const 'Exn.keepHistory true' endif -bin/lacweb: src/lacweb.mlb src/*.sig src/*.sml +bin/lacweb: src/lacweb.mlb src/*.sig src/*.sml \ + src/lacweb.mlton.lex.sml \ + src/lacweb.mlton.grm.sig src/lacweb.mlton.grm.sml $(MLTON) -output $@ src/lacweb.mlb
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/compiler.sig Sat Jan 26 12:35:32 2008 -0500 @@ -0,0 +1,36 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Laconic/Web main compiler interface *) + +signature COMPILER = sig + + val parse : string -> Laconic.file option + + val testParse : string -> unit + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/compiler.sml Sat Jan 26 12:35:32 2008 -0500 @@ -0,0 +1,64 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Laconic/Web language parser *) + +structure Compiler :> COMPILER = struct + +structure LacwebLrVals = LacwebLrValsFn(structure Token = LrParser.Token) +structure Lex = LacwebLexFn(structure Tokens = LacwebLrVals.Tokens) +structure LacwebP = Join(structure ParserData = LacwebLrVals.ParserData + structure Lex = Lex + structure LrParser = LrParser) + +(* The main parsing routine *) +fun parse filename = + let + val () = (ErrorMsg.resetErrors (); + ErrorMsg.resetPositioning filename) + val file = TextIO.openIn filename + fun get _ = TextIO.input file + fun parseerror (s, p1, p2) = ErrorMsg.errorAt' (p1, p2) s + val lexer = LrParser.Stream.streamify (Lex.makeLexer get) + val (absyn, _) = LacwebP.parse (30, lexer, parseerror, ()) + in + TextIO.closeIn file; + SOME absyn + end + handle LrParser.ParseError => NONE + +fun testParse filename = + case parse filename of + NONE => print "Parse error\n" + | SOME file => + if ErrorMsg.anyErrors () then + print "Recoverable parse error\n" + else + (Print.print (LaconicPrint.p_file file); + print "\n") + +end
--- a/src/errormsg.sig Sat Jan 26 10:06:22 2008 -0500 +++ b/src/errormsg.sig Sat Jan 26 12:35:32 2008 -0500 @@ -36,4 +36,18 @@ type 'a located = 'a * span + val posToString : pos -> string + val spanToString : span -> string + + val resetPositioning : string -> unit + val newline : int -> unit + val lastLineStart : unit -> int + val posOf : int -> pos + val spanOf : int * int -> span + + val resetErrors : unit -> unit + val anyErrors : unit -> bool + val error : string -> unit + val errorAt : span -> string -> unit + val errorAt' : int * int -> string -> unit end
--- a/src/errormsg.sml Sat Jan 26 10:06:22 2008 -0500 +++ b/src/errormsg.sml Sat Jan 26 12:35:32 2008 -0500 @@ -36,4 +36,61 @@ type 'a located = 'a * span + +fun posToString {line, char} = + String.concat [Int.toString line, ":", Int.toString char] + +fun spanToString {file, first, last} = + String.concat [file, ":", posToString first, "-", posToString last] + + +val file = ref "" +val numLines = ref 1 +val lines : int list ref = ref [] + +fun resetPositioning fname = (file := fname; + numLines := 1; + lines := []) + +fun newline pos = (numLines := !numLines + 1; + lines := pos :: !lines) + +fun lastLineStart () = + case !lines of + [] => 0 + | n :: _ => n+1 + +fun posOf n = + let + fun search lineNum lines = + case lines of + [] => {line = 1, + char = n} + | bound :: rest => + if n > bound then + {line = lineNum, + char = n - bound - 1} + else + search (lineNum - 1) rest + in + search (!numLines) (!lines) + end + +fun spanOf (pos1, pos2) = {file = !file, + first = posOf pos1, + last = posOf pos2} + + +val errors = ref false + +fun resetErrors () = errors := false +fun anyErrors () = !errors +fun error s = (TextIO.output (TextIO.stdErr, s); + TextIO.output1 (TextIO.stdErr, #"\n"); + errors := true) +fun errorAt span s = (TextIO.output (TextIO.stdErr, spanToString span); + TextIO.output1 (TextIO.stdErr, #" "); + error s) +fun errorAt' span s = errorAt (spanOf span) s + end
--- a/src/laconic.sml Sat Jan 26 10:06:22 2008 -0500 +++ b/src/laconic.sml Sat Jan 26 12:35:32 2008 -0500 @@ -37,23 +37,33 @@ withtype kind = kind' located +datatype explicitness = + Explicit + | Implicit + datatype con' = CAnnot of con * kind | TFun of con * con - | TCFun of bool * string option * kind * con + | TCFun of explicitness * string * kind * con | TRecord of con - | CFvar of string - | CBvar of int + | CVar of string | CApp of con * con - | CAbs of string * kind * con + | CAbs of explicitness * string * kind * con | CName of string - | CRecord of (string * con) list + | CRecord of (con * con) list | CConcat of con * con withtype con = con' located +datatype decl' = + DCon of string * kind option * con + +withtype decl = decl' located + +type file = decl list + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/laconic_print.sig Sat Jan 26 12:35:32 2008 -0500 @@ -0,0 +1,36 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Pretty-printing Laconic/Web *) + +signature LACONIC_PRINT = sig + val p_kind : Laconic.kind Print.printer + val p_explicitness : Laconic.explicitness Print.printer + val p_con : Laconic.con Print.printer + val p_decl : Laconic.decl Print.printer + val p_file : Laconic.file Print.printer +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/laconic_print.sml Sat Jan 26 12:35:32 2008 -0500 @@ -0,0 +1,147 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Pretty-printing Laconic/Web *) + +structure LaconicPrint :> LACONIC_PRINT = struct + +open Print.PD +open Print + +open Laconic + +fun p_kind' par (k, _) = + case k of + KType => string "Type" + | KArrow (k1, k2) => parenIf par (box [p_kind' true k1, + space, + string "->", + space, + p_kind k2]) + | KName => string "Name" + | KRecord k => box [string "{", p_kind k, string "}"] + +and p_kind k = p_kind' false k + +fun p_explicitness e = + case e of + Explicit => string "::" + | Implicit => string ":::" + +fun p_con' par (c, _) = + case c of + CAnnot (c, k) => box [string "(", + p_con c, + space, + string "::", + space, + p_kind k, + string ")"] + + | TFun (t1, t2) => parenIf par (box [p_con' true t1, + space, + string "->", + space, + p_con t2]) + | TCFun (e, x, k, c) => parenIf par (box [string x, + space, + p_explicitness e, + space, + p_kind k, + space, + string "->", + space, + p_con c]) + | TRecord (CRecord xcs, _) => box [string "{", + p_list (fn (x, c) => + box [p_con x, + space, + string ":", + space, + p_con c]) xcs, + string "}"] + | TRecord c => box [string "$", + p_con' true c] + + | CVar s => string s + | CApp (c1, c2) => parenIf par (box [p_con c1, + space, + p_con' true c2]) + | CAbs (e, x, k, c) => parenIf par (box [string "fn", + space, + string x, + space, + p_explicitness e, + space, + p_kind k, + space, + string "=>", + space, + p_con c]) + + | CName s => box [string "#", string s] + + | CRecord xcs => box [string "[", + p_list (fn (x, c) => + box [p_con x, + space, + string "=", + space, + p_con c]) xcs, + string "]"] + | CConcat (c1, c2) => parenIf par (box [p_con' true c1, + space, + string "++", + space, + p_con c2]) + +and p_con c = p_con' false c + +fun p_decl ((d, _) : decl) = + case d of + DCon (x, NONE, c) => box [string "con", + space, + string x, + space, + string "=", + space, + p_con c] + | DCon (x, SOME k, c) => box [string "con", + space, + string x, + space, + string "::", + space, + p_kind k, + space, + string "=", + space, + p_con c] + +val p_file = p_list_sep newline p_decl + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/lacweb.grm Sat Jan 26 12:35:32 2008 -0500 @@ -0,0 +1,126 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Grammar for Laconic/Web programs *) + +open Laconic + +val s = ErrorMsg.spanOf + +%% +%header (functor LacwebLrValsFn(structure Token : TOKEN)) + +%term + EOF + | SYMBOL of string | CSYMBOL of string + | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE + | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH + | CON | TYPE | NAME + | ARROW | LARROW | DARROW + | FN | PLUSPLUS | DOLLAR + +%nonterm + file of decl list + | decls of decl list + | decl of decl + + | kind of kind + | kcolon of explicitness + + | cexp of con + | capps of con + | cterm of con + | ident of con + | rcon of (con * con) list + | rcone of (con * con) list + +%verbose (* print summary of errors *) +%pos int (* positions *) +%start file +%pure +%eop EOF +%noshift EOF + +%name Lacweb + +%nonassoc DARROW +%nonassoc COLON +%right COMMA +%right ARROW LARROW +%right PLUSPLUS +%nonassoc DOLLAR +%left DOT + +%% + +file : decls (decls) + +decls : ([]) + | decl decls (decl :: decls) + +decl : CON SYMBOL EQ cexp (DCon (SYMBOL, NONE, cexp), s (CONleft, cexpright)) + | CON SYMBOL DCOLON kind EQ cexp (DCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright)) + +kind : TYPE (KType, s (TYPEleft, TYPEright)) + | NAME (KName, s (NAMEleft, NAMEright)) + | LBRACE kind RBRACE (KRecord kind, s (LBRACEleft, RBRACEright)) + | kind ARROW kind (KArrow (kind1, kind2), s (kind1left, kind2right)) + | LPAREN kind RPAREN (#1 kind, s (LPARENleft, RPARENright)) + +capps : cterm (cterm) + | capps cterm (CApp (capps, cterm), s (cappsleft, ctermright)) + +cexp : capps (capps) + | cexp ARROW cexp (TFun (cexp1, cexp2), s (cexp1left, cexp2right)) + | SYMBOL kcolon kind ARROW cexp (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright)) + + | cexp PLUSPLUS cexp (CConcat (cexp1, cexp2), s (cexp1left, cexp1right)) + + | FN SYMBOL kcolon kind DARROW cexp (CAbs (kcolon, SYMBOL, kind, cexp), s (FNleft, cexpright)) + +kcolon : DCOLON (Explicit) + | TCOLON (Implicit) + +cterm : LPAREN cexp RPAREN (#1 cexp, s (LPARENleft, RPARENright)) + | LBRACK rcon RBRACK (CRecord rcon, s (LBRACKleft, RBRACKright)) + | LBRACE rcone RBRACE (TRecord (CRecord rcone, s (LBRACEleft, RBRACEright)), + s (LBRACEleft, RBRACEright)) + | DOLLAR cterm (TRecord cterm, s (DOLLARleft, ctermright)) + | HASH CSYMBOL (CName CSYMBOL, s (HASHleft, CSYMBOLright)) + + | SYMBOL (CVar SYMBOL, s (SYMBOLleft, SYMBOLright)) + +rcon : ([]) + | ident EQ cexp ([(ident, cexp)]) + | ident EQ cexp COMMA rcon ((ident, cexp) :: rcon) + +rcone : ([]) + | ident COLON cexp ([(ident, cexp)]) + | ident COLON cexp COMMA rcone ((ident, cexp) :: rcone) + +ident : CSYMBOL (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright)) + | SYMBOL (CVar SYMBOL, s (SYMBOLleft, SYMBOLright))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/lacweb.lex Sat Jan 26 12:35:32 2008 -0500 @@ -0,0 +1,124 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Lexing info for Laconic/Web programs *) + +type pos = int +type svalue = Tokens.svalue +type ('a,'b) token = ('a,'b) Tokens.token +type lexresult = (svalue,pos) Tokens.token + +local + val commentLevel = ref 0 + val commentPos = ref 0 +in + fun enterComment pos = + (if !commentLevel = 0 then + commentPos := pos + else + (); + commentLevel := !commentLevel + 1) + + fun exitComment () = + (ignore (commentLevel := !commentLevel - 1); + !commentLevel = 0) + + fun eof () = + let + val pos = ErrorMsg.lastLineStart () + in + if !commentLevel > 0 then + ErrorMsg.errorAt' (!commentPos, !commentPos) "Unterminated comment" + else + (); + Tokens.EOF (pos, pos) + end +end + +%% +%header (functor LacwebLexFn(structure Tokens : Lacweb_TOKENS)); +%full +%s COMMENT; + +id = [a-z_][A-Za-z0-9_]*; +cid = [A-Z][A-Za-z0-9_]*; +ws = [\ \t\012]; + +%% + +<INITIAL> \n => (ErrorMsg.newline yypos; + continue ()); +<COMMENT> \n => (ErrorMsg.newline yypos; + continue ()); + +<INITIAL> {ws}+ => (lex ()); + +<INITIAL> "(*" => (YYBEGIN COMMENT; + enterComment yypos; + continue ()); +<INITIAL> "*)" => (ErrorMsg.errorAt' (yypos, yypos) "Unbalanced comments"; + continue ()); + +<COMMENT> "(*" => (enterComment yypos; + continue ()); +<COMMENT> "*)" => (if exitComment () then YYBEGIN INITIAL else (); + continue ()); + +<INITIAL> "(" => (Tokens.LPAREN (yypos, yypos + size yytext)); +<INITIAL> ")" => (Tokens.RPAREN (yypos, yypos + size yytext)); +<INITIAL> "[" => (Tokens.LBRACK (yypos, yypos + size yytext)); +<INITIAL> "]" => (Tokens.RBRACK (yypos, yypos + size yytext)); +<INITIAL> "{" => (Tokens.LBRACE (yypos, yypos + size yytext)); +<INITIAL> "}" => (Tokens.RBRACE (yypos, yypos + size yytext)); + +<INITIAL> "->" => (Tokens.ARROW (yypos, yypos + size yytext)); +<INITIAL> "=>" => (Tokens.DARROW (yypos, yypos + size yytext)); +<INITIAL> "++" => (Tokens.PLUSPLUS (yypos, yypos + size yytext)); + +<INITIAL> "=" => (Tokens.EQ (yypos, yypos + size yytext)); +<INITIAL> "," => (Tokens.COMMA (yypos, yypos + size yytext)); +<INITIAL> ":::" => (Tokens.TCOLON (yypos, yypos + size yytext)); +<INITIAL> "::" => (Tokens.DCOLON (yypos, yypos + size yytext)); +<INITIAL> ":" => (Tokens.COLON (yypos, yypos + size yytext)); +<INITIAL> "." => (Tokens.DOT (yypos, yypos + size yytext)); +<INITIAL> "$" => (Tokens.DOLLAR (yypos, yypos + size yytext)); +<INITIAL> "#" => (Tokens.HASH (yypos, yypos + size yytext)); + +<INITIAL> "con" => (Tokens.CON (yypos, yypos + size yytext)); +<INITIAL> "fn" => (Tokens.FN (yypos, yypos + size yytext)); + +<INITIAL> "Type" => (Tokens.TYPE (yypos, yypos + size yytext)); +<INITIAL> "Name" => (Tokens.NAME (yypos, yypos + size yytext)); + +<INITIAL> {id} => (Tokens.SYMBOL (yytext, yypos, yypos + size yytext)); +<INITIAL> {cid} => (Tokens.CSYMBOL (yytext, yypos, yypos + size yytext)); + +<COMMENT> . => (continue()); + +<INITIAL> . => (ErrorMsg.errorAt' (yypos, yypos) + ("illegal character: \"" ^ yytext ^ "\""); + continue ());
--- a/src/main.mlton.sml Sat Jan 26 10:06:22 2008 -0500 +++ b/src/main.mlton.sml Sat Jan 26 12:35:32 2008 -0500 @@ -25,3 +25,6 @@ * POSSIBILITY OF SUCH DAMAGE. *) +val () = case CommandLine.arguments () of + [filename] => Compiler.testParse filename + | _ => print "Bad arguments"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/print.sig Sat Jan 26 12:35:32 2008 -0500 @@ -0,0 +1,54 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Pretty-printing *) + +signature PRINT = sig + structure PD : PP_DESC + where type PPS.token = string + + type 'a printer = 'a -> PD.pp_desc + + val box : PD.pp_desc list -> PD.pp_desc + val parenIf : bool -> PD.pp_desc -> PD.pp_desc + val space : PD.pp_desc + + val p_list_sep : PD.pp_desc -> 'a printer -> 'a list printer + val p_list : 'a printer -> 'a list printer + + val fprint : PD.PPS.stream -> PD.pp_desc -> unit + val print : PD.pp_desc -> unit + val eprint : PD.pp_desc -> unit + + val fpreface : PD.PPS.stream -> string * PD.pp_desc -> unit + val preface : string * PD.pp_desc -> unit + val epreface : string * PD.pp_desc -> unit + + val fprefaces : PD.PPS.stream -> (string * PD.pp_desc) list -> unit + val prefaces : (string * PD.pp_desc) list -> unit + val eprefaces : (string * PD.pp_desc) list -> unit +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/print.sml Sat Jan 26 12:35:32 2008 -0500 @@ -0,0 +1,92 @@ +(* Copyright (c) 2008, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +(* Pretty-printing Laconic/Web *) + +structure Print :> PRINT = struct + +structure SM = TextIOPP +structure PD = PPDescFn(SM) + +type 'a printer = 'a -> PD.pp_desc + +fun box ds = PD.hovBox (PD.PPS.Rel 1, ds) +fun parenIf b d = + if b then + box [PD.string "(", d, PD.string ")"] + else + d +val space = PD.space 1 + +val out = SM.openOut {dst = TextIO.stdOut, wid = 70} +val err = SM.openOut {dst = TextIO.stdErr, wid = 70} + +fun p_list_sep sep f ls = + case ls of + [] => PD.string "" + | [x] => f x + | x :: rest => + let + val tokens = foldr (fn (x, tokens) => + sep :: f x :: tokens) + [] rest + in + box (f x :: tokens) + end +fun p_list f = p_list_sep (box [PD.string ",", space]) f + +fun fprint f d = (PD.description (f, d); + PD.PPS.flushStream f) +val print = fprint out +val eprint = fprint err + +fun fpreface f (s, d) = + fprint f (PD.hovBox (PD.PPS.Rel 0, + [PD.string s, PD.space 1, d])) + +val preface = fpreface out +val epreface = fpreface err + +fun fprefaces f ls = + let + val len = foldl (fn ((s, _), best) => + Int.max (size s, best)) 0 ls + in + app (fn (s, d) => + let + val s = CharVector.tabulate (len - size s, + fn _ => #" ") + ^ s ^ ": " + in + fpreface f (s, d) + end) ls + end + +val prefaces = fprefaces out +val eprefaces = fprefaces err + +end
--- a/src/sources Sat Jan 26 10:06:22 2008 -0500 +++ b/src/sources Sat Jan 26 12:35:32 2008 -0500 @@ -2,3 +2,15 @@ errormsg.sml laconic.sml + +lacweb.grm +lacweb.lex + +print.sig +print.sml + +laconic_print.sig +laconic_print.sml + +compiler.sig +compiler.sml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/stuff.lac Sat Jan 26 12:35:32 2008 -0500 @@ -0,0 +1,10 @@ +con c1 = t :: Type -> t +con c2 :: Type = t :: Type -> t +con c3 = fn t :: Type => c1 +con c4 = c3 c1 +con c5 = (fn t :: Type => c1) c1 + +con name = #MyName + +con c6 = {A : c1, name : c2} +con c7 = [A = c1, name = c2]