Merge pull request #380 from melt-umn/develop

Silver 0.4.4 release

Jenkinsfile

@@ -94,7 +94,8 @@ melt.trynode('silver') {
 
   stage("Integration") {
     // Projects with 'develop' as main branch, we'll try to build specific branch names if they exist
-    def github_projects = ["/melt-umn/ableC", "/melt-umn/Oberon0", "/melt-umn/ableJ14", "/melt-umn/meta-ocaml-lite", "/melt-umn/rewriting-lambda-calculus",
+    def github_projects = ["/melt-umn/ableC", "/melt-umn/Oberon0", "/melt-umn/ableJ14", "/melt-umn/meta-ocaml-lite",
+                           "/melt-umn/rewriting-lambda-calculus", "/melt-umn/rewriting-regex-matching", "/melt-umn/rewriting-optimization-demo",
                            "/internal/ring"]
     // Specific other jobs to build
     def specific_jobs = ["/internal/matlab/master", "/internal/metaII/master", "/internal/simple/master"]

grammars/core/List.sv

@@ -277,6 +277,12 @@ function repeat
          else v :: repeat(v, times-1);
 }
 
+function range
+[Integer] ::= lower::Integer upper::Integer
+{
+  return if lower >= upper then [] else lower :: range(lower + 1, upper);
+}
+
 function zipWith
 [c] ::= f::(c ::= a b)  l1::[a]  l2::[b]
 {

grammars/silver/composed/idetest/Analyze.sv

@@ -9,6 +9,8 @@ import silver:util:cmdargs;
 import silver:definition:core;
 import silver:definition:env;
 
+import silver:rewrite;
+
 -- This function is mostly copied from function cmdLineRun in driver/BuildProcess.sv
 function ideAnalyze
 IOVal<[Message]> ::= args::[String]  svParser::SVParser ioin::IO
@@ -102,12 +104,12 @@ function rewriteMessages
 function rewriteMessage
 Message ::= path::String m::Message
 {
-  return case m of
-  | err(loc(file, a, b, c, d, e, f), g) -> err(loc(path ++ "/" ++ file, a, b, c, d, e, f), g)
-  | wrn(loc(file, a, b, c, d, e, f), g) -> wrn(loc(path ++ "/" ++ file, a, b, c, d, e, f), g)
-  | info(loc(file, a, b, c, d, e, f), g) -> info(loc(path ++ "/" ++ file, a, b, c, d, e, f), g)
-  | nested(loc(file, a, b, c, d, e, f), g, others) ->
-    nested(loc(path ++ "/" ++ file, a, b, c, d, e, f), g, map(rewriteMessage(path, _), others))
-  end;
+  return
+    rewriteWith(
+      allTopDown(
+        rule on Location of
+        | loc(file, a, b, c, d, e, f) -> loc(path ++ "/" ++ file, a, b, c, d, e, f)
+        end),
+      m).fromJust;
 }
 

grammars/silver/definition/core/QName.sv

@@ -216,6 +216,8 @@ top::QNameAttrOccur ::= at::QName
   top.dcl = if top.found then head(dclsNarrowed) else
     error("INTERNAL ERROR: Accessing dcl of occurrence " ++ at.name ++ " at " ++ top.grammarName ++ " " ++ top.location.unparse);
   top.attrDcl = if top.found then head(attrsNarrowed) else
+    -- Workaround fix for proper error reporting - appairently there are some places where this is still demanded.
+    if !null(at.lookupAttribute.dcls) then head(at.lookupAttribute.dcls) else
     error("INTERNAL ERROR: Accessing dcl of attribute " ++ at.name ++ " at " ++ top.grammarName ++ " " ++ top.location.unparse);
 }
 

grammars/silver/extension/autoattr/Functor.sv

@@ -22,6 +22,7 @@ top::AGDcl ::= 'functor' 'attribute' a::Name ';'
 abstract production functorAttributionDcl
 top::AGDcl ::= at::Decorated QName attl::BracketedOptTypeExprs nt::QName nttl::BracketedOptTypeExprs
 {
+  top.unparse = "attribute " ++ at.unparse ++ attl.unparse ++ " occurs on " ++ nt.unparse ++ nttl.unparse ++ ";";
   forwards to
     defaultAttributionDcl(
       at,
@@ -45,31 +46,29 @@ top::AGDcl ::= at::Decorated QName attl::BracketedOptTypeExprs nt::QName nttl::B
 abstract production propagateFunctor
 top::ProductionStmt ::= attr::Decorated QName
 {
+  top.unparse = s"propagate ${attr.unparse};";
+
   -- No explicit errors, for now.  The only conceivable issue is the attribute not
   -- occuring on the LHS but this should be caught by the forward errors.  
 
   -- Generate the arguments for the constructor
-  local topName::QName = qName(top.location, top.frame.signature.outputElement.elementName);
-  local prodName::QName = qName(top.location, top.frame.fullName);
-  prodName.grammarName = top.grammarName;
-  prodName.config = top.config;
-  prodName.env = top.env;
-
   local inputs :: [Expr] = 
     map(makeArg(top.location, top.env, attr, _), top.frame.signature.inputElements);
   local annotations :: [Pair<String Expr>] = 
-    map(makeAnnoArg(top.location, topName, _), top.frame.signature.namedInputElements);
+    map(
+      makeAnnoArg(top.location, top.frame.signature.outputElement.elementName, _),
+      top.frame.signature.namedInputElements);
 
   -- Construct an attribute def and call with the generated arguments
-  forwards to 
+  forwards to
     attributeDef(
-      concreteDefLHS(topName, location=top.location),
+      concreteDefLHS(qName(top.location, top.frame.signature.outputElement.elementName), location=top.location),
       '.',
       qNameAttrOccur(new(attr), location=top.location),
       '=',
       mkFullFunctionInvocation(
         top.location,
-        baseExpr(prodName, location=top.location),
+        baseExpr(qName(top.location, top.frame.fullName), location=top.location),
         inputs,
         annotations),
       ';',
@@ -112,7 +111,7 @@ Expr ::= loc::Location env::Decorated Env attrName::Decorated QName input::Named
  - @return A list of AnnoExprs to be used to build the named arguments
  -}
 function makeAnnoArg
-Pair<String Expr> ::= loc::Location baseName::QName input::NamedSignatureElement
+Pair<String Expr> ::= loc::Location baseName::String input::NamedSignatureElement
 {
   -- TODO: This is a hacky way of getting the base name, not sure if correct
   -- trouble is the annotations are listed as fullnames, but have to be supplied as shortnames. weird.
@@ -121,7 +120,7 @@ Pair<String Expr> ::= loc::Location baseName::QName input::NamedSignatureElement
   return
     pair(annoName,
       access(
-        baseExpr(baseName, location=loc), '.',
+        baseExpr(qName(loc, baseName), location=loc), '.',
         qNameAttrOccur(qName(loc, annoName), location=loc),
         location=loc));
 }

grammars/silver/extension/autoattr/Monoid.sv

@@ -84,6 +84,8 @@ top::Operation ::=
 abstract production propagateMonoid
 top::ProductionStmt ::= attr::Decorated QName
 {
+  top.unparse = s"propagate ${attr.unparse};";
+
   -- No explicit errors, for now.  The only conceivable issue is the attribute not
   -- occuring on the LHS but this should be caught by the forward errors.  
 
@@ -94,13 +96,6 @@ top::ProductionStmt ::= attr::Decorated QName
         input.typerep.isDecorable &&
         !null(getOccursDcl(attrFullName, input.typerep.typeName, top.env)),
       top.frame.signature.inputElements);
-
-  local topName::QName = qName(top.location, top.frame.signature.outputElement.elementName);
-  local prodName::QName = qName(top.location, top.frame.fullName);
-  prodName.grammarName = top.grammarName;
-  prodName.config = top.config;
-  prodName.env = top.env;
-
   local res :: Expr = 
     if null(inputsWithAttr)
     then attr.lookupAttribute.dcl.emptyVal
@@ -119,7 +114,7 @@ top::ProductionStmt ::= attr::Decorated QName
   -- Construct an attribute def and call with the generated arguments
   forwards to
     attrContainsBase(
-      concreteDefLHS(topName, location=top.location),
+      concreteDefLHS(qName(top.location, top.frame.signature.outputElement.elementName), location=top.location),
       '.',
       qNameAttrOccur(new(attr), location=top.location),
       ':=', res, ';', location=top.location);

grammars/silver/extension/autoattr/Propagate.sv

@@ -69,7 +69,7 @@ top::AGDcl ::= d::DclInfo attrs::NameList
   top.errors :=
     if null(forward.errors)
     then []
-    else [nested(top.location, s"In propagate for production ${d.fullName}:", forward.errors)];
+    else [nested(top.location, s"In propagate of ${attrs.unparse} for production ${d.fullName}:", forward.errors)];
 
   forwards to
     aspectProductionDcl(

grammars/silver/extension/convenience/Productions.sv

@@ -2,6 +2,14 @@ grammar silver:extension:convenience;
 
 import silver:modification:copper;
 
+-- "production" short for "abstract production"
+concrete production productionDclImplicitAbs
+top::AGDcl ::= 'production' id::Name ns::ProductionSignature body::ProductionBody
+{
+  forwards to productionDcl('abstract', $1, id, ns, body, location=top.location);
+}
+
+-- "concrete productions" syntax
 nonterminal ProductionDclStmts with unparse, location, proddcls, lhsdcl, grammarName;
 nonterminal ProductionDclStmt with unparse, location, proddcls, lhsdcl, grammarName;
 

grammars/silver/extension/patternmatching/Case.sv

@@ -14,18 +14,19 @@ terminal Arrow_kwd '->' lexer classes {SPECOP};
 terminal Vbar_kwd '|' lexer classes {SPECOP};
 terminal Opt_Vbar_t /\|?/ lexer classes {SPECOP}; -- optional Coq-style vbar.
 terminal When_kwd 'when' lexer classes {KEYWORD,RESERVED};
+terminal Matches_kwd 'matches' lexer classes {KEYWORD};
 
 -- MR | ...
-nonterminal MRuleList with location, config, unparse, env, errors, matchRuleList, matchRulePatternSize;
+nonterminal MRuleList with location, config, unparse, env, frame, errors, matchRuleList, matchRulePatternSize;
 
 -- Turns MRuleList (of MatchRules) into [AbstractMatchRule]
 synthesized attribute matchRuleList :: [AbstractMatchRule];
 -- Notification of the number of expressions being matched upon
 autocopy attribute matchRulePatternSize :: Integer;
 
 -- P -> E
-nonterminal MatchRule with location, config, unparse, env, errors, matchRuleList, matchRulePatternSize;
-nonterminal AbstractMatchRule with location, headPattern, isVarMatchRule, expandHeadPattern;
+nonterminal MatchRule with location, config, unparse, env, frame, errors, matchRuleList, matchRulePatternSize;
+nonterminal AbstractMatchRule with location, unparse, headPattern, isVarMatchRule, expandHeadPattern;
 
 -- The head pattern of a match rule
 synthesized attribute headPattern :: Decorated Pattern;
@@ -35,7 +36,7 @@ synthesized attribute isVarMatchRule :: Boolean;
 synthesized attribute expandHeadPattern :: (AbstractMatchRule ::= [String]);
 
 -- P , ...
-nonterminal PatternList with location, config, unparse, patternList, env, errors, patternVars, patternVarEnv;
+nonterminal PatternList with location, config, unparse, patternList, env, frame, errors, patternVars, patternVarEnv;
 
 -- Turns PatternList into [Pattern]
 synthesized attribute patternList :: [Decorated Pattern];
@@ -75,13 +76,18 @@ top::Expr ::= 'case' es::Exprs 'of' Opt_Vbar_t ml::MRuleList 'end'
 abstract production caseExpr
 top::Expr ::= es::[Expr] ml::[AbstractMatchRule] failExpr::Expr retType::Type
 {
-  top.unparse = error("Internal error: pretty of intermediate data structure");
+  top.unparse =
+    "(case " ++ implode(", ", map((.unparse), es)) ++ " of " ++ 
+    implode(" | ", map((.unparse), ml)) ++ " | _ -> " ++ failExpr.unparse ++
+    " end :: " ++ prettyType(retType) ++ ")";
 
   -- 4 cases: no patterns left, all constructors, all variables, or mixed con/var.
   -- errors cases: more patterns no scrutinees, more scrutinees no patterns, no scrutinees multiple rules
   forwards to
     case ml of
     | matchRule([], c, e) :: _ -> buildMatchWhenConditionals(ml, failExpr) -- valid or error case
+    -- No match rules, only possible through abstract syntax
+    | [] -> Silver_Expr { let res :: $TypeExpr{typerepTypeExpr(retType, location=top.location)} = $Expr{failExpr} in res end }
     | _ -> if null(es) then failExpr -- error case
            else if null(varRules) then allConCase
            else if null(prodRules) then allVarCase
@@ -141,17 +147,59 @@ top::Expr ::= es::[Expr] ml::[AbstractMatchRule] failExpr::Expr retType::Type
       -- So don't try that!
 
   {--
-   - Mixed con/var? Partition, and push the vars into the "fail" branch.
-   - Use a let for it, to avoid code duplication!
+    - Mixed con/var? Partition into segments and build nested case expressions
+    - The whole segment partitioning is done in a function rather than grabbing the initial segment
+      and forwarding to do the rest of the segments (another workable option) for efficiency
    -}
+  local mixedCase :: Expr = buildMixedCaseMatches(es, ml, failExpr, retType, top.location);
+}
+
+
+--Get the initial segment of the match rules which all have the same
+--pattern type (constructor or var) and the rest of the rules
+function initialSegmentPatternType
+Pair<[AbstractMatchRule] [AbstractMatchRule]> ::= lst::[AbstractMatchRule]
+{
+  return case lst of
+           --this probably shouldn't be called with an empty list, but catch it anyway
+         | [] -> pair([], [])
+         | [mr] -> pair([mr], [])
+         | mr1::mr2::rest ->
+           if mr1.isVarMatchRule == mr2.isVarMatchRule
+           then --both have the same type of pattern
+              let sub::Pair<[AbstractMatchRule] [AbstractMatchRule]> = initialSegmentPatternType(mr2::rest)
+              in pair(mr1::sub.fst, sub.snd) end
+           else --the first has a different type of pattern than the second
+              pair([mr1], mr2::rest)
+         end;
+}
+
+{-
+  Build the correct match expression when we are mixing constructor
+  and variable patterns for the first match.  We do this by
+  partitioning the list into segments of only constructor or variable
+  patterns in order, then putting each segment into its own match.
+-}
+function buildMixedCaseMatches
+Expr ::= es::[Expr] ml::[AbstractMatchRule] failExpr::Expr retType::Type loc::Location
+{
   local freshFailName :: String = "__fail_" ++ toString(genInt());
-  local mixedCase :: Expr =
-    makeLet(top.location,
-      freshFailName, retType, caseExpr(es, varRules, failExpr, retType, location=top.location),
-      caseExpr(es, prodRules, baseExpr(qName(top.location, freshFailName), location=top.location),
-        retType, location=top.location));
+  return if null(ml)
+         then failExpr
+         else let segments::Pair<[AbstractMatchRule] [AbstractMatchRule]> =
+                            initialSegmentPatternType(ml)
+              in
+                makeLet(loc, freshFailName, retType,
+                        buildMixedCaseMatches(es, segments.snd, failExpr, retType, loc),
+                        caseExpr(es, segments.fst, baseExpr(qName(loc, freshFailName), location=loc),
+                                 retType, location=loc))
+              end;
 }
 
+
+
+
+--Match Rules
 concrete production mRuleList_one
 top::MRuleList ::= m::MatchRule
 {
@@ -197,12 +245,36 @@ top::MatchRule ::= pt::PatternList 'when' cond::Expr '->' e::Expr
 
   pt.patternVarEnv = [];
 
-  top.matchRuleList = [matchRule(pt.patternList, just(cond), e, location=top.location)];
+  top.matchRuleList = [matchRule(pt.patternList, just(pair(cond, nothing())), e, location=top.location)];
+}
+
+concrete production matchRuleWhenMatches_c
+top::MatchRule ::= pt::PatternList 'when' cond::Expr 'matches' p::Pattern '->' e::Expr
+{
+  top.unparse = pt.unparse ++ " when " ++ cond.unparse ++ " matches " ++ p.unparse ++ " -> " ++ e.unparse;
+  top.errors := pt.errors; -- e.errors is examined later, after transformation, as is cond.errors
+
+  top.errors <-
+    if length(pt.patternList) == top.matchRulePatternSize then []
+    else [err(pt.location, "case expression matching against " ++ toString(top.matchRulePatternSize) ++ " values, but this rule has " ++ toString(length(pt.patternList)) ++ " patterns")];
+
+  pt.patternVarEnv = [];
+  p.patternVarEnv = pt.patternVars;
+
+  top.matchRuleList = [matchRule(pt.patternList, just(pair(cond, just(p))), e, location=top.location)];
 }
 
 abstract production matchRule
-top::AbstractMatchRule ::= pl::[Decorated Pattern] cond::Maybe<Expr> e::Expr
+top::AbstractMatchRule ::= pl::[Decorated Pattern] cond::Maybe<Pair<Expr Maybe<Pattern>>> e::Expr
 {
+  top.unparse =
+    implode(", ", map((.unparse), pl)) ++
+    case cond of
+    | just(pair(c, just(p))) -> " when " ++ c.unparse ++ " matches " ++ p.unparse
+    | just(pair(c, nothing())) -> " when " ++ c.unparse
+    | nothing() -> ""
+    end ++
+    " -> " ++ e.unparse;
   top.headPattern = head(pl);
   -- If pl is null, and we're consulted, then we're missing patterns, pretend they're _
   top.isVarMatchRule = null(pl) || head(pl).patternIsVariable;
@@ -374,15 +446,18 @@ AbstractMatchRule ::= headExpr::Expr  headType::Type  absRule::AbstractMatchRule
   -- If it's '_' we do nothing, otherwise, bind away!
   return case absRule of
   | matchRule(headPat :: restPat, cond, e) ->
-      matchRule(restPat,
-        case headPat.patternVariableName, cond of
-        | just(pvn), just(c) -> just(makeLet(absRule.location, pvn, headType, headExpr, c))
-        | _, _ -> cond
+    case headPat.patternVariableName of
+    | just(pvn) ->
+      matchRule(
+        restPat,
+        case cond of
+        | just(pair(c, p)) -> just(pair(makeLet(absRule.location, pvn, headType, headExpr, c), p))
+        | nothing() -> nothing()
         end,
-        case headPat.patternVariableName of
-        | just(pvn) -> makeLet(absRule.location, pvn, headType, headExpr, e)
-        | nothing() -> e
-        end, location=absRule.location)
+        makeLet(absRule.location, pvn, headType, headExpr, e),
+        location=absRule.location)
+    | nothing() -> matchRule(restPat, cond, e, location=absRule.location)
+    end
   end;
 }
 
@@ -437,11 +512,18 @@ Expr ::= ml::[AbstractMatchRule] failExpr::Expr
 {
   return
     case ml of
-    | matchRule(_, just(c), e) :: tl ->
+    | matchRule(_, just(pair(c, nothing())), e) :: tl ->
+      Silver_Expr {
+        if $Expr{c}
+        then $Expr{e}
+        else $Expr{buildMatchWhenConditionals(tl, failExpr)}
+      }
+    | matchRule(_, just(pair(c, just(p))), e) :: tl ->
       Silver_Expr {
-        if $Expr {c}
-        then $Expr {e}
-        else $Expr {buildMatchWhenConditionals(tl, failExpr)}
+        case $Expr{c} of
+        | $Pattern{p} -> $Expr{e}
+        | _ -> $Expr{buildMatchWhenConditionals(tl, failExpr)}
+        end
       }
     | matchRule(_, nothing(), e) :: tl -> e
     | [] -> failExpr

grammars/silver/extension/patternmatching/PatternTypes.sv

@@ -5,7 +5,7 @@ import silver:extension:list only LSqr_t, RSqr_t;
 {--
  - The forms of syntactic patterns that are permissible in (nested) case expresssions.
  -}
-nonterminal Pattern with location, config, unparse, env, errors, patternVars, patternVarEnv, patternIsVariable, patternVariableName, patternSubPatternList, patternNamedSubPatternList, patternSortKey;
+nonterminal Pattern with location, config, unparse, env, frame, errors, patternVars, patternVarEnv, patternIsVariable, patternVariableName, patternSubPatternList, patternNamedSubPatternList, patternSortKey;
 
 {--
  - The names of all var patterns in the pattern.