Functor parsing

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