Improved Easy_domain, with boolean env vars

diff --git a/elisp/domtool-mode.el b/elisp/domtool-mode.el
index 292acfa..9330e0b 100644 (file)
--- a/elisp/domtool-mode.el
+++ b/elisp/domtool-mode.el
@@ -46,7 +46,7 @@
   `(,(concat
       "\\_<"
       (regexp-opt '("let" "in" "begin" "end" "with" "where" "extern" "type"
   `(,(concat
       "\\_<"
       (regexp-opt '("let" "in" "begin" "end" "with" "where" "extern" "type"

-                    "val" "context" "Root")
+                    "val" "context" "Root" "if" "then" "else")

                   t)
       "\\_>")
 
                   t)
       "\\_>")
 

diff --git a/lib/alias.dtl b/lib/alias.dtl
index 6e0a3ff..e84d0a7 100644 (file)
--- a/lib/alias.dtl
+++ b/lib/alias.dtl
@@ -13,11 +13,7 @@ extern type aliasSource;
 extern val userSource : emailUser -> aliasSource;
 {{The part appear before the "@" in your desired source address}}
 extern val defaultSource : aliasSource;
 extern val userSource : emailUser -> aliasSource;
 {{The part appear before the "@" in your desired source address}}
 extern val defaultSource : aliasSource;

-{{Matches any mail to this domain that doesn't match any other rule, with the
-  exception of systemwide usernames like UNIX users.}}
-extern val catchAllSource : aliasSource;
-{{Matches any mail to this domain that doesn't match any other rule, even
-  for systemwide usernames.}}
+{{Matches any mail to this domain that doesn't match any other rule.}}

 
 extern type aliasTarget;
 {{A place to redirect messages}}
 
 extern type aliasTarget;
 {{A place to redirect messages}}


@@ -41,8 +37,5 @@ val aliasDrop = \user -> aliasPrim (userSource user) dropTarget;
 {{Silently delete mail to the user at the current domain.}}
 
 val defaultAlias = \email -> aliasPrim defaultSource (addressTarget email);
 {{Silently delete mail to the user at the current domain.}}
 
 val defaultAlias = \email -> aliasPrim defaultSource (addressTarget email);

-{{When a message to the current domain doesn't match any other alias and isn't a
-  UNIX username, send it to this e-mail address.}}
-val catchAllAlias = \email -> aliasPrim catchAllSource (addressTarget email);
-{{When a message to the current domain doesn't match any other alias, send it to
+{{When a message to the current domain doesn't match any other rule, send it to

   this e-mail address.}}
   this e-mail address.}}

diff --git a/lib/easy_domain.dtl b/lib/easy_domain.dtl
index 952bcfb..9934be4 100644 (file)
--- a/lib/easy_domain.dtl
+++ b/lib/easy_domain.dtl
@@ -30,9 +30,9 @@ val webAtIp =
          end
        end;
 
          end
        end;
 

-val addCatchAllAlias = begin
+val addDefaultAlias = begin

   mailbox <- Mailbox;
   mailbox <- Mailbox;

-  catchAllAlias mailbox
+  defaultAlias mailbox

 end;
 
 val addWww = begin
 end;
 
 val addWww = begin


@@ -43,7 +43,7 @@ val addWww = begin
   end
 end;
 
   end
 end;
 

-val domNoWwwNoDefaultAlias =
+val dom =

        \ d : (your_domain) ->
        \\ config : Domain ->
                domain d with
        \ d : (your_domain) ->
        \\ config : Domain ->
                domain d with


@@ -55,31 +55,21 @@ val domNoWwwNoDefaultAlias =
                        handleMail;
                        dns (dnsMX 1 "deleuze.hcoop.net");
 
                        handleMail;
                        dns (dnsMX 1 "deleuze.hcoop.net");
 

-                       config
-               end;
-
-val domNoDefaultAlias =
-       \ d : (your_domain) ->
-       \\ config : Domain ->
-               domNoWwwNoDefaultAlias d with
-                 addWww;
-                 config
-               end;
+                       createWWW : bool <- CreateWWW;
+                       if createWWW then
+                         addWww
+                       else
+                         Skip
+                       end;

 
 

-val domNoWww =
-       \ d : (your_domain) ->
-       \\ config : Domain ->
-               domNoWwwNoDefaultAlias d with
-                 config;
-                 addCatchAllAlias;
-               end;
+                       defAl : bool <- DefaultAlias;
+                       if defAl then
+                         addDefaultAlias
+                       else
+                         Skip
+                       end;

 
 

-val dom =
-       \ d : (your_domain) ->
-       \\ config : Domain ->
-               domNoDefaultAlias d with
-                 config;
-                 addCatchAllAlias;
+                       config

                end;
 
 val nameserver = \host -> dns (dnsNS host);
                end;
 
 val nameserver = \host -> dns (dnsNS host);

diff --git a/src/domtool.grm b/src/domtool.grm
index c9cd837..0cc4fbd 100644 (file)
--- a/src/domtool.grm
+++ b/src/domtool.grm
@@ -33,7 +33,7 @@ open Ast
  | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
  | EQ | COMMA | BSLASH | BSLASHBSLASH | SEMI | LET | IN | BEGIN | END
  | IF | THEN | ELSE
  | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
  | EQ | COMMA | BSLASH | BSLASHBSLASH | SEMI | LET | IN | BEGIN | END
  | IF | THEN | ELSE

- | ROOT
+ | ROOT | SKIP

  | EXTERN | TYPE | VAL | WITH | WHERE | CONTEXT
 
 %nonterm 
  | EXTERN | TYPE | VAL | WITH | WHERE | CONTEXT
 
 %nonterm 


@@ -65,6 +65,7 @@ open Ast
 
 %name Domtool
 
 
 %name Domtool
 

+%nonassoc THEN ELSE

 %right SEMI
 %nonassoc COLON
 %nonassoc IN
 %right SEMI
 %nonassoc COLON
 %nonassoc IN


@@ -129,7 +130,7 @@ exp    : apps                              (apps)
        | exp SEMI                          (exp)
        | SYMBOL LARROW CSYMBOL SEMI exp    (EGet (SYMBOL, NONE, CSYMBOL, exp), (SYMBOLleft, expright))
        | SYMBOL COLON typ LARROW CSYMBOL SEMI exp (EGet (SYMBOL, SOME typ, CSYMBOL, exp), (SYMBOLleft, expright))
        | exp SEMI                          (exp)
        | SYMBOL LARROW CSYMBOL SEMI exp    (EGet (SYMBOL, NONE, CSYMBOL, exp), (SYMBOLleft, expright))
        | SYMBOL COLON typ LARROW CSYMBOL SEMI exp (EGet (SYMBOL, SOME typ, CSYMBOL, exp), (SYMBOLleft, expright))

-       | IF exp THEN exp ELSE exp          (EIf (exp1, exp2, exp3), (IFleft, exp3right))
+       | IF exp THEN exp ELSE exp END      (EIf (exp1, exp2, exp3), (IFleft, ENDright))

 
 apps   : term                              (term)
        | apps term                         (EApp (apps, term), (appsleft, termright))
 
 apps   : term                              (term)
        | apps term                         (EApp (apps, term), (appsleft, termright))


@@ -141,6 +142,7 @@ term   : LPAREN exp RPAREN                 (exp)
        | LBRACK elist RBRACK               (EList elist, (LBRACKleft, RBRACKright))
        | LET exp IN exp END                (ELocal (exp1, exp2), (LETleft, ENDright))
        | SYMBOL                            (EVar SYMBOL, (SYMBOLleft, SYMBOLright))
        | LBRACK elist RBRACK               (EList elist, (LBRACKleft, RBRACKright))
        | LET exp IN exp END                (ELocal (exp1, exp2), (LETleft, ENDright))
        | SYMBOL                            (EVar SYMBOL, (SYMBOLleft, SYMBOLright))

+       | SKIP                              (ESkip, (SKIPleft, SKIPright))

 
 sets   : CSYMBOL EQ apps SEMIopt           ([(ESet (CSYMBOL, apps), (CSYMBOLleft, appsright))])
        | CSYMBOL EQ apps SEMI sets         ((ESet (CSYMBOL, apps), (CSYMBOLleft, appsright))
 
 sets   : CSYMBOL EQ apps SEMIopt           ([(ESet (CSYMBOL, apps), (CSYMBOLleft, appsright))])
        | CSYMBOL EQ apps SEMI sets         ((ESet (CSYMBOL, apps), (CSYMBOLleft, appsright))

diff --git a/src/domtool.lex b/src/domtool.lex
index dd4391b..4f51821 100644 (file)
--- a/src/domtool.lex
+++ b/src/domtool.lex
@@ -133,6 +133,7 @@ lineComment = #[^\n]*\n;
 <INITIAL> "if"        => (Tokens.IF (yypos, yypos + size yytext));
 <INITIAL> "then"      => (Tokens.THEN (yypos, yypos + size yytext));
 <INITIAL> "else"      => (Tokens.ELSE (yypos, yypos + size yytext));
 <INITIAL> "if"        => (Tokens.IF (yypos, yypos + size yytext));
 <INITIAL> "then"      => (Tokens.THEN (yypos, yypos + size yytext));
 <INITIAL> "else"      => (Tokens.ELSE (yypos, yypos + size yytext));

+<INITIAL> "Skip"      => (Tokens.SKIP (yypos, yypos + size yytext));

 
 <INITIAL> "extern"    => (Tokens.EXTERN (yypos, yypos + size yytext));
 <INITIAL> "type"      => (Tokens.TYPE (yypos, yypos + size yytext));
 
 <INITIAL> "extern"    => (Tokens.EXTERN (yypos, yypos + size yytext));
 <INITIAL> "type"      => (Tokens.TYPE (yypos, yypos + size yytext));

diff --git a/src/eval.sml b/src/eval.sml
index 1fec487..c41f796 100644 (file)
--- a/src/eval.sml
+++ b/src/eval.sml
@@ -60,7 +60,12 @@ fun exec' evs (eAll as (e, _)) =
     case e of
        ESkip => SM.empty
       | ESet (ev, e) => SM.insert (SM.empty, ev, e)
     case e of
        ESkip => SM.empty
       | ESet (ev, e) => SM.insert (SM.empty, ev, e)

-      | EGet (x, _, ev, e) => exec' evs (Reduce.subst x (lookup (evs, ev)) e)
+      | EGet (x, _, ev, e) =>
+       let
+           val e' = Reduce.subst x (lookup (evs, ev)) e
+       in
+           exec' evs (Reduce.reduceExp Env.empty e')
+       end

       | ESeq es =>
        let
            val (new, _) =
       | ESeq es =>
        let
            val (new, _) =

diff --git a/src/plugins/easy_domain.sml b/src/plugins/easy_domain.sml
index 24aa83f..70a3601 100644 (file)
--- a/src/plugins/easy_domain.sml
+++ b/src/plugins/easy_domain.sml
@@ -30,4 +30,12 @@ val _ = Defaults.registerDefault ("WWW",
                                            StringMap.empty), dl),
                                  (fn () => (ESkip, dl)))
 
                                            StringMap.empty), dl),
                                  (fn () => (ESkip, dl)))
 

+val _ = Defaults.registerDefault ("CreateWWW",
+                                 (TBase "bool", dl),
+                                 (fn () => (EVar "true", dl)))
+
+val _ = Defaults.registerDefault ("DefaultAlias",
+                                 (TBase "bool", dl),
+                                 (fn () => (EVar "true", dl)))
+

 end
 end

diff --git a/src/printFn.sml b/src/printFn.sml
index decc2bc..42282aa 100644 (file)
--- a/src/printFn.sml
+++ b/src/printFn.sml
@@ -134,7 +134,7 @@ fun p_exp' pn (e, _) =
       | EWith (e1, e2) => dBox [p_exp e1, space 1, keyword "with", p_exp e2, space 1, keyword "end"]
       | EIf (e1, e2, e3) => dBox [keyword "if", space 1, p_exp e1,
                                  space 1, keyword "then", space 1, p_exp e2,
       | EWith (e1, e2) => dBox [p_exp e1, space 1, keyword "with", p_exp e2, space 1, keyword "end"]
       | EIf (e1, e2, e3) => dBox [keyword "if", space 1, p_exp e1,
                                  space 1, keyword "then", space 1, p_exp e2,

-                                 space 1, keyword "else", space 1, p_exp e2]
+                                 space 1, keyword "else", space 1, p_exp e3]

 and p_exp e = p_exp' false e
 
 fun p_decl d =
 and p_exp e = p_exp' false e
 
 fun p_decl d =

diff --git a/src/tycheck.sml b/src/tycheck.sml
index f68100f..d5b3f1e 100644 (file)
--- a/src/tycheck.sml
+++ b/src/tycheck.sml
@@ -574,8 +574,6 @@ fun checkExp G (eAll as (e, loc)) =
 
          | EIf (e1, e2, e3) =>
            let
 
          | EIf (e1, e2, e3) =>
            let

-               val t = (newUnif (), loc)
-

                val t1 = checkExp G e1
                val t2 = checkExp G e2
                val t3 = checkExp G e3
                val t1 = checkExp G e1
                val t2 = checkExp G e2
                val t3 = checkExp G e3


@@ -583,20 +581,21 @@ fun checkExp G (eAll as (e, loc)) =
            in
                (subTyp (t1, bool))
                handle Unify ue =>
            in
                (subTyp (t1, bool))
                handle Unify ue =>

-                      dte (WrongType ("\"If\" test",
+                      dte (WrongType ("\"if\" test",

                                       e1,
                                       t1,
                                       bool,
                                       SOME ue));
                                       e1,
                                       t1,
                                       bool,
                                       SOME ue));

-               subTyp (t2, t);
-               (subTyp (t3, t))
-               handle Unify ue =>
-                      dte (WrongType ("\"Else\" case",
-                                      eAll,
-                                      t3,
-                                      t2,
-                                      SOME ue));
-               t
+               (subTyp (t2, t3); t3)
+                      handle Unify _ =>
+                             ((subTyp (t3, t2); t2)
+                              handle Unify ue =>
+                                     (dte (WrongType ("\"else\" case",
+                                                      eAll,
+                                                      t3,
+                                                      t2,
+                                                      SOME ue));
+                                      (TError, loc)))

            end
     end
 
            end
     end