summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-06-19 15:15:00 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-06-19 15:15:00 -0400
commit5a4ddea95a551c5f95f0dcbda433fe457b61d25a (patch)
tree60135c04bf54aba0d443ec39a4dc37ec0f399852
parent8e98be7de2dd3db541994aae47aeb45756f60098 (diff)
Functor parsing
-rw-r--r--src/elaborate.sml2
-rw-r--r--src/lacweb.grm8
-rw-r--r--src/lacweb.lex1
-rw-r--r--src/source.sml2
-rw-r--r--src/source_print.sml40
-rw-r--r--tests/functor.lac15
6 files changed, 67 insertions, 1 deletions
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 29d12b07..d482f9a0 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1097,6 +1097,7 @@ and elabSgn env (sgn, loc) =
(sgnError env (UnboundSgn (loc, x));
(L'.SgnError, loc))
| SOME (n, sgis) => (L'.SgnVar n, loc))
+ | L.SgnFun _ => raise Fail "Elaborate functor sig"
fun sgiOfDecl (d, loc) =
case d of
@@ -1343,6 +1344,7 @@ and elabStr env (str, loc) =
(strerror, sgnerror))
| SOME sgn => ((L'.StrProj (str', x), loc), sgn)
end
+ | L.StrFun _ => raise Fail "Elaborate functor"
val elabFile = ListUtil.foldlMap elabDecl
diff --git a/src/lacweb.grm b/src/lacweb.grm
index f8f54fca..ea40c236 100644
--- a/src/lacweb.grm
+++ b/src/lacweb.grm
@@ -44,7 +44,7 @@ val s = ErrorMsg.spanOf
| TYPE | NAME
| ARROW | LARROW | DARROW
| FN | PLUSPLUS | DOLLAR
- | STRUCTURE | SIGNATURE | STRUCT | SIG | END
+ | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR
%nonterm
file of decl list
@@ -113,6 +113,8 @@ decl : CON SYMBOL EQ cexp (DCon (SYMBOL, NONE, cexp), s (CONleft,
sgn : SIG sgis END (SgnConst sgis, s (SIGleft, ENDright))
| CSYMBOL (SgnVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
+ | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
+ (SgnFun (CSYMBOL, sgn1, sgn2), s (FUNCTORleft, sgn2right))
sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, kindright))
| LTYPE SYMBOL (SgiConAbs (SYMBOL, (KType, s (LTYPEleft, SYMBOLright))),
@@ -130,6 +132,10 @@ sgis : ([])
str : STRUCT decls END (StrConst decls, s (STRUCTleft, ENDright))
| spath (spath)
+ | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN DARROW str
+ (StrFun (CSYMBOL, sgn, NONE, str), s (FUNCTORleft, strright))
+ | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn DARROW str
+ (StrFun (CSYMBOL, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))
spath : CSYMBOL (StrVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
| spath DOT CSYMBOL (StrProj (spath, CSYMBOL), s (spathleft, CSYMBOLright))
diff --git a/src/lacweb.lex b/src/lacweb.lex
index c5ce7ae8..56f19060 100644
--- a/src/lacweb.lex
+++ b/src/lacweb.lex
@@ -133,6 +133,7 @@ realconst = [0-9]+\.[0-9]*;
<INITIAL> "struct" => (Tokens.STRUCT (yypos, yypos + size yytext));
<INITIAL> "sig" => (Tokens.SIG (yypos, yypos + size yytext));
<INITIAL> "end" => (Tokens.END (yypos, yypos + size yytext));
+<INITIAL> "functor" => (Tokens.FUNCTOR (yypos, yypos + size yytext));
<INITIAL> "Type" => (Tokens.TYPE (yypos, yypos + size yytext));
<INITIAL> "Name" => (Tokens.NAME (yypos, yypos + size yytext));
diff --git a/src/source.sml b/src/source.sml
index a7ff04c6..6f8c932f 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -71,6 +71,7 @@ datatype sgn_item' =
and sgn' =
SgnConst of sgn_item list
| SgnVar of string
+ | SgnFun of string * sgn * sgn
withtype sgn_item = sgn_item' located
and sgn = sgn' located
@@ -100,6 +101,7 @@ datatype decl' =
StrConst of decl list
| StrVar of string
| StrProj of str * string
+ | StrFun of string * sgn * sgn option * str
withtype decl = decl' located
and str = str' located
diff --git a/src/source_print.sml b/src/source_print.sml
index 2005d09f..fb416a60 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -247,6 +247,18 @@ and p_sgn (sgn, _) =
newline,
string "end"]
| SgnVar x => string x
+ | SgnFun (x, sgn, sgn') => box [string "functor",
+ space,
+ string "(",
+ string x,
+ space,
+ string ":",
+ p_sgn sgn,
+ string ")",
+ space,
+ string ":",
+ space,
+ p_sgn sgn']
fun p_decl ((d, _) : decl) =
case d of
@@ -324,6 +336,34 @@ and p_str (str, _) =
| StrProj (str, x) => box [p_str str,
string ".",
string x]
+ | StrFun (x, sgn, NONE, str) => box [string "functor",
+ space,
+ string "(",
+ string x,
+ space,
+ string ":",
+ p_sgn sgn,
+ string ")",
+ space,
+ string "=>",
+ space,
+ p_str str]
+ | StrFun (x, sgn, SOME sgn', str) => box [string "functor",
+ space,
+ string "(",
+ string x,
+ space,
+ string ":",
+ p_sgn sgn,
+ string ")",
+ space,
+ string ":",
+ space,
+ p_sgn sgn',
+ space,
+ string "=>",
+ space,
+ p_str str]
val p_file = p_list_sep newline p_decl
diff --git a/tests/functor.lac b/tests/functor.lac
new file mode 100644
index 00000000..ef81300d
--- /dev/null
+++ b/tests/functor.lac
@@ -0,0 +1,15 @@
+signature S = sig
+ type t
+ val z : t
+ val s : t -> t
+end
+
+signature T = sig
+ type t
+ val three : t
+end
+
+structure F = functor (M : S) : T => struct
+ val t = M.t
+ val three = M.s (M.s (M.s M.z))
+end