changeset 30:e6ccf961d8a3

Parsing and printing basic module system
author Adam Chlipala <adamc@hcoop.net>
date Thu, 12 Jun 2008 14:04:22 -0400
parents 537db4ee89f4
children 1c91c5e6840f
files src/elaborate.sml src/lacweb.grm src/lacweb.lex src/source.sml src/source_print.sml
diffstat 5 files changed, 209 insertions(+), 59 deletions(-) [+]
line wrap: on
line diff
--- a/src/elaborate.sml	Tue Jun 10 18:28:43 2008 -0400
+++ b/src/elaborate.sml	Thu Jun 12 14:04:22 2008 -0400
@@ -865,74 +865,81 @@
          eprefaces' [("Expression", p_exp env e)])
 
 fun elabDecl env (d, loc) =
-    (resetKunif ();
-     resetCunif ();
-     case d of
-         L.DCon (x, ko, c) =>
-         let
-             val k' = case ko of
-                          NONE => kunif ()
-                        | SOME k => elabKind k
+    let
+        
+    in
+        resetKunif ();
+        resetCunif ();
+        case d of
+            L.DCon (x, ko, c) =>
+            let
+                val k' = case ko of
+                             NONE => kunif ()
+                           | SOME k => elabKind k
 
-             val (c', ck) = elabCon env c
-             val (env', n) = E.pushCNamed env x k' (SOME c')
-         in
-             checkKind env c' ck k';
+                val (c', ck) = elabCon env c
+                val (env', n) = E.pushCNamed env x k' (SOME c')
+            in
+                checkKind env c' ck k';
 
-             if ErrorMsg.anyErrors () then
-                 ()
-             else (
-                 if kunifsInKind k' then
-                     declError env (KunifsRemainKind (loc, k'))
-                 else
-                     ();
+                if ErrorMsg.anyErrors () then
+                    ()
+                else (
+                    if kunifsInKind k' then
+                        declError env (KunifsRemainKind (loc, k'))
+                    else
+                        ();
 
-                 if kunifsInCon c' then
-                     declError env (KunifsRemainCon (loc, c'))
-                 else
-                     ()
-                 );
+                    if kunifsInCon c' then
+                        declError env (KunifsRemainCon (loc, c'))
+                    else
+                        ()
+                    );
 
-             (env',
-              (L'.DCon (x, n, k', c'), loc))
-         end
-       | L.DVal (x, co, e) =>
-         let
-             val (c', ck) = case co of
-                                NONE => (cunif ktype, ktype)
-                              | SOME c => elabCon env c
+                (env',
+                 (L'.DCon (x, n, k', c'), loc))
+            end
+          | L.DVal (x, co, e) =>
+            let
+                val (c', ck) = case co of
+                                   NONE => (cunif ktype, ktype)
+                                 | SOME c => elabCon env c
 
-             val (e', et) = elabExp env e
-             val (env', n) = E.pushENamed env x c'
-         in
-             checkCon env e' et c';
+                val (e', et) = elabExp env e
+                val (env', n) = E.pushENamed env x c'
+            in
+                checkCon env e' et c';
 
-             if ErrorMsg.anyErrors () then
-                 ()
-             else (
-                 if kunifsInCon c' then
-                     declError env (KunifsRemainCon (loc, c'))
-                 else
-                     ();
+                if ErrorMsg.anyErrors () then
+                    ()
+                else (
+                    if kunifsInCon c' then
+                        declError env (KunifsRemainCon (loc, c'))
+                    else
+                        ();
 
-                 if cunifsInCon c' then
-                     declError env (CunifsRemainCon (loc, c'))
-                 else
-                     ();
+                    if cunifsInCon c' then
+                        declError env (CunifsRemainCon (loc, c'))
+                    else
+                        ();
 
-                 if kunifsInExp e' then
-                     declError env (KunifsRemainExp (loc, e'))
-                 else
-                     ();
+                    if kunifsInExp e' then
+                        declError env (KunifsRemainExp (loc, e'))
+                    else
+                        ();
 
-                 if cunifsInExp e' then
-                     declError env (CunifsRemainExp (loc, e'))
-                 else
-                     ());
+                    if cunifsInExp e' then
+                        declError env (CunifsRemainExp (loc, e'))
+                    else
+                        ());
 
-             (env',
-              (L'.DVal (x, n, c', e'), loc))
-         end)
+                (env',
+                 (L'.DVal (x, n, c', e'), loc))
+            end
+
+          | L.DSgn _ => raise Fail "Not ready to elaborate signature"
+          | L.DStr _ => raise Fail "Not ready to elaborate structure"
+    end
 
 fun elabFile env ds =
     ListUtil.mapfoldl (fn (d, env) => elabDecl env d) env ds
--- a/src/lacweb.grm	Tue Jun 10 18:28:43 2008 -0400
+++ b/src/lacweb.grm	Thu Jun 12 14:04:22 2008 -0400
@@ -44,12 +44,19 @@
  | TYPE | NAME
  | ARROW | LARROW | DARROW
  | FN | PLUSPLUS | DOLLAR
+ | STRUCTURE | SIGNATURE | STRUCT | SIG | END
 
-%nonterm 
+%nonterm
    file of decl list
  | decls of decl list
  | decl of decl
 
+ | sgn of sgn
+ | sgi of sgn_item
+ | sgis of sgn_item list
+
+ | str of str
+
  | kind of kind
  | kcolon of explicitness
 
@@ -97,6 +104,30 @@
        | VAL SYMBOL EQ eexp             (DVal (SYMBOL, NONE, eexp), s (VALleft, eexpright))
        | VAL SYMBOL COLON cexp EQ eexp  (DVal (SYMBOL, SOME cexp, eexp), s (VALleft, eexpright))
 
+       | SIGNATURE CSYMBOL EQ sgn       (DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))
+       | STRUCTURE CSYMBOL EQ str       (DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright))
+       | STRUCTURE CSYMBOL COLON sgn EQ str (DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright))
+
+sgn    : SIG sgis END                   (SgnConst sgis, s (SIGleft, ENDright))
+       | CSYMBOL                        (SgnVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
+
+sgi    : CON SYMBOL DCOLON kind         (SgiConAbs (SYMBOL, kind), s (CONleft, kindright))
+       | LTYPE SYMBOL                   (SgiConAbs (SYMBOL, (KType, s (LTYPEleft, SYMBOLright))),
+                                         s (LTYPEleft, SYMBOLright))
+       | CON SYMBOL EQ cexp             (SgiCon (SYMBOL, NONE, cexp), s (CONleft, cexpright))
+       | CON SYMBOL DCOLON kind EQ cexp (SgiCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright))
+       | LTYPE SYMBOL EQ cexp           (SgiCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
+                                         s (LTYPEleft, cexpright))
+       | VAL SYMBOL COLON cexp          (SgiVal (SYMBOL, cexp), s (VALleft, cexpright))
+
+       | STRUCTURE CSYMBOL COLON sgn    (SgiStr (CSYMBOL, sgn), s (STRUCTUREleft, sgnright))
+
+sgis   :                                ([])
+       | sgi sgis                       (sgi :: sgis)
+
+str    : STRUCT decls END               (StrConst decls, s (STRUCTleft, ENDright))
+       | CSYMBOL                        (StrVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
+
 kind   : TYPE                           (KType, s (TYPEleft, TYPEright))
        | NAME                           (KName, s (NAMEleft, NAMEright))
        | LBRACE kind RBRACE             (KRecord kind, s (LBRACEleft, RBRACEright))
--- a/src/lacweb.lex	Tue Jun 10 18:28:43 2008 -0400
+++ b/src/lacweb.lex	Thu Jun 12 14:04:22 2008 -0400
@@ -128,6 +128,12 @@
 <INITIAL> "val"       => (Tokens.VAL (yypos, yypos + size yytext));
 <INITIAL> "fn"        => (Tokens.FN (yypos, yypos + size yytext));
 
+<INITIAL> "structure" => (Tokens.STRUCTURE (yypos, yypos + size yytext));
+<INITIAL> "signature" => (Tokens.STRUCTURE (yypos, yypos + size yytext));
+<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> "Type"      => (Tokens.TYPE (yypos, yypos + size yytext));
 <INITIAL> "Name"      => (Tokens.NAME (yypos, yypos + size yytext));
 
--- a/src/source.sml	Tue Jun 10 18:28:43 2008 -0400
+++ b/src/source.sml	Thu Jun 12 14:04:22 2008 -0400
@@ -77,11 +77,31 @@
 
 withtype exp = exp' located
 
+datatype sgn_item' =
+         SgiConAbs of string * kind
+       | SgiCon of string * kind option * con
+       | SgiVal of string * con
+       | SgiStr of string * sgn
+
+and sgn' =
+    SgnConst of sgn_item list
+  | SgnVar of string
+
+withtype sgn_item = sgn_item' located
+and sgn = sgn' located
+
 datatype decl' =
          DCon of string * kind option * con
        | DVal of string * con option * exp
+       | DSgn of string * sgn
+       | DStr of string * sgn option * str
+
+     and str' =
+         StrConst of decl list
+       | StrVar of string
 
 withtype decl = decl' located
+     and str = str' located
 
 type file = decl list
 
--- a/src/source_print.sml	Tue Jun 10 18:28:43 2008 -0400
+++ b/src/source_print.sml	Thu Jun 12 14:04:22 2008 -0400
@@ -197,6 +197,57 @@
 
 and p_exp e = p_exp' false e
 
+fun p_sgn_item (sgi, _) =
+    case sgi of
+        SgiConAbs (x, k) => box [string "con",
+                                 space,
+                                 string x,
+                                 space,
+                                 string "::",
+                                 space,
+                                 p_kind k]
+      | SgiCon (x, NONE, c) => box [string "con",
+                                    space,
+                                    string x,
+                                    space,
+                                    string "=",
+                                    space,
+                                    p_con c]
+      | SgiCon (x, SOME k, c) => box [string "con",
+                                      space,
+                                      string x,
+                                      space,
+                                      string "::",
+                                      space,
+                                      p_kind k,
+                                      space,
+                                      string "=",
+                                      space,
+                                      p_con c]
+      | SgiVal (x, c) => box [string "val",
+                              space,
+                              string x,
+                              space,
+                              string ":",
+                              space,
+                              p_con c]
+      | SgiStr (x, sgn) => box [string "structure",
+                                space,
+                                string x,
+                                space,
+                                string ":",
+                                space,
+                                p_sgn sgn]
+
+and p_sgn (sgn, _) =
+    case sgn of
+        SgnConst sgis => box [string "sig",
+                              newline,
+                              p_list_sep newline p_sgn_item sgis,
+                              newline,
+                              string "end"]
+      | SgnVar x => string x
+                                 
 fun p_decl ((d, _) : decl) =
     case d of
         DCon (x, NONE, c) => box [string "con",
@@ -236,6 +287,41 @@
                                     space,
                                     p_exp e]
 
+      | DSgn (x, sgn) => box [string "signature",
+                              space,
+                              string x,
+                              space,
+                              string "=",
+                              space,
+                              p_sgn sgn]
+      | DStr (x, NONE, str) => box [string "structure",
+                                    space,
+                                    string x,
+                                    space,
+                                    string "=",
+                                    space,
+                                    p_str str]
+      | DStr (x, SOME sgn, str) => box [string "structure",
+                                        space,
+                                        string x,
+                                        space,
+                                        string ":",
+                                        space,
+                                        p_sgn sgn,
+                                        space,
+                                        string "=",
+                                        space,
+                                        p_str str]
+
+and p_str (str, _) =
+    case str of
+        StrConst ds => box [string "struct",
+                            newline,
+                            p_list_sep newline p_decl ds,
+                            newline,
+                            string "end"]
+      | StrVar x => string x
+
 val p_file = p_list_sep newline p_decl
 
 end