From a356587aacf682b584fbbebf7b999154755e80c7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 15 Dec 2007 20:17:26 +0000 Subject: [PATCH] Improved Easy_domain, with boolean env vars --- elisp/domtool-mode.el | 2 +- lib/alias.dtl | 11 ++-------- lib/easy_domain.dtl | 42 ++++++++++++++----------------------- src/domtool.grm | 6 ++++-- src/domtool.lex | 1 + src/eval.sml | 7 ++++++- src/plugins/easy_domain.sml | 8 +++++++ src/printFn.sml | 2 +- src/tycheck.sml | 23 ++++++++++---------- 9 files changed, 50 insertions(+), 52 deletions(-) diff --git a/elisp/domtool-mode.el b/elisp/domtool-mode.el index 292acfa..9330e0b 100644 --- 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" - "val" "context" "Root") + "val" "context" "Root" "if" "then" "else") t) "\\_>") diff --git a/lib/alias.dtl b/lib/alias.dtl index 6e0a3ff..e84d0a7 100644 --- 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; -{{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}} @@ -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); -{{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.}} diff --git a/lib/easy_domain.dtl b/lib/easy_domain.dtl index 952bcfb..9934be4 100644 --- a/lib/easy_domain.dtl +++ b/lib/easy_domain.dtl @@ -30,9 +30,9 @@ val webAtIp = end end; -val addCatchAllAlias = begin +val addDefaultAlias = begin mailbox <- Mailbox; - catchAllAlias mailbox + defaultAlias mailbox end; val addWww = begin @@ -43,7 +43,7 @@ val addWww = begin end end; -val domNoWwwNoDefaultAlias = +val dom = \ d : (your_domain) -> \\ config : Domain -> domain d with @@ -55,31 +55,21 @@ val domNoWwwNoDefaultAlias = 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); diff --git a/src/domtool.grm b/src/domtool.grm index c9cd837..0cc4fbd 100644 --- 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 - | ROOT + | ROOT | SKIP | EXTERN | TYPE | VAL | WITH | WHERE | CONTEXT %nonterm @@ -65,6 +65,7 @@ open Ast %name Domtool +%nonassoc THEN ELSE %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)) - | 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)) @@ -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)) + | SKIP (ESkip, (SKIPleft, SKIPright)) 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 --- a/src/domtool.lex +++ b/src/domtool.lex @@ -133,6 +133,7 @@ lineComment = #[^\n]*\n; "if" => (Tokens.IF (yypos, yypos + size yytext)); "then" => (Tokens.THEN (yypos, yypos + size yytext)); "else" => (Tokens.ELSE (yypos, yypos + size yytext)); + "Skip" => (Tokens.SKIP (yypos, yypos + size yytext)); "extern" => (Tokens.EXTERN (yypos, yypos + size yytext)); "type" => (Tokens.TYPE (yypos, yypos + size yytext)); diff --git a/src/eval.sml b/src/eval.sml index 1fec487..c41f796 100644 --- 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) - | 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, _) = diff --git a/src/plugins/easy_domain.sml b/src/plugins/easy_domain.sml index 24aa83f..70a3601 100644 --- 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))) +val _ = Defaults.registerDefault ("CreateWWW", + (TBase "bool", dl), + (fn () => (EVar "true", dl))) + +val _ = Defaults.registerDefault ("DefaultAlias", + (TBase "bool", dl), + (fn () => (EVar "true", dl))) + end diff --git a/src/printFn.sml b/src/printFn.sml index decc2bc..42282aa 100644 --- 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, - 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 = diff --git a/src/tycheck.sml b/src/tycheck.sml index f68100f..d5b3f1e 100644 --- a/src/tycheck.sml +++ b/src/tycheck.sml @@ -574,8 +574,6 @@ fun checkExp G (eAll as (e, loc)) = | EIf (e1, e2, e3) => let - val t = (newUnif (), loc) - 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 => - dte (WrongType ("\"If\" test", + dte (WrongType ("\"if\" test", 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 -- 2.20.1