Implement DeadNTermTagsElim transform with tests

src/Transform/DeadNTermTagsElim.fram

@@ -10,8 +10,177 @@ be used. This optimization reduces the number of non-terminals generated by
 ##}
 
 import open Repr/RichGrammar
+import open Utils/UID
+import List
+import Map
+
+let (Map { module TagMap }) = Map.make { Key = String }
+let (Map { module UIDMap }) = Map.make { Key = UID }
+
+type TagSet = TagMap.T Unit
+type MayTags = NTermMap.T TagSet
+type VarEnv = UIDMap.T NTermId
+type Atom = Pair Tag UID
+type Valuation = List (Pair Atom Bool)
+
+{# This pass assumes a valid RichGrammar: TC_Tag variables must be bound by
+PS_NTerm symbols, not by tokens. Missing bindings are invariant violations. #}
+let mayTagsOf (mayTags : MayTags) (id : NTermId) =
+  mayTags.findErr
+    { ~onError = fn _ => impossible () }
+    id
+
+let initMayTags nterms =
+  List.foldLeft
+    (fn (mayTags : MayTags) (nt : NTerm) =>
+      mayTags.add nt.id TagMap.empty)
+    NTermMap.empty
+    nterms
+
+let addMayTag (mayTags : MayTags) (id : NTermId) tag =
+  let tagSet = mayTagsOf mayTags id in
+  if tagSet.mem tag then
+    (mayTags, False)
+  else
+    (mayTags.add id (tagSet.add tag ()), True)
+
+let addSymbolVar (varEnv : VarEnv) sym =
+  match sym with
+  | PS_Token _ => varEnv
+  | PS_NTerm {var} id => varEnv.add var.id id
+  end
+
+let prodVarEnv (prod : NTermProd) =
+  List.foldLeft addSymbolVar UIDMap.empty prod.symbols
+
+let lookupVarNTerm (varEnv : VarEnv) (var : Var) =
+  varEnv.findErr { ~onError = fn _ => impossible () } var.id
+
+let atomPossible mayTags varEnv tag var =
+  let ntermId = lookupVarNTerm varEnv var in
+  (mayTagsOf mayTags ntermId).mem tag
+
+let sameAtom ((tag1, id1) : Atom) ((tag2, id2) : Atom) =
+  tag1 == tag2 && id1 == id2
+
+let hasAtom atom atoms =
+  List.exists (sameAtom atom) atoms
+
+let addAtom atom atoms =
+  if hasAtom atom atoms then atoms else atom :: atoms
+
+let rec collectPossibleAtoms mayTags varEnv cond atoms =
+  match cond with
+  | TC_True => atoms
+  | TC_False => atoms
+  | TC_Tag tag var =>
+    if atomPossible mayTags varEnv tag var then
+      addAtom (tag, var.id) atoms
+    else
+      atoms
+  | TC_And cond1 cond2 =>
+    atoms
+    |> collectPossibleAtoms mayTags varEnv cond1
+    |> collectPossibleAtoms mayTags varEnv cond2
+  | TC_Or cond1 cond2 =>
+    atoms
+    |> collectPossibleAtoms mayTags varEnv cond1
+    |> collectPossibleAtoms mayTags varEnv cond2
+  end
+
+let rec allValuations atoms =
+  match atoms with
+  | [] => [[]]
+  | atom :: atoms =>
+    allValuations atoms
+    |> List.concatMap
+        (fn (valuation : Valuation) =>
+          [ (atom, True) :: valuation
+          , (atom, False) :: valuation
+          ])
+  end
+
+let atomValue (valuation : Valuation) atom =
+  valuation
+  |> List.findErr
+      { ~onError = fn _ => impossible () }
+      (fn ((atom', _) : Pair Atom Bool) => sameAtom atom atom')
+  |> snd
+
+let rec evalCond mayTags varEnv valuation cond =
+  match cond with
+  | TC_True => True
+  | TC_False => False
+  | TC_Tag tag var =>
+    if atomPossible mayTags varEnv tag var then
+      atomValue valuation (tag, var.id)
+    else
+      False
+  | TC_And cond1 cond2 =>
+    evalCond mayTags varEnv valuation cond1
+    && evalCond mayTags varEnv valuation cond2
+  | TC_Or cond1 cond2 =>
+    evalCond mayTags varEnv valuation cond1
+    || evalCond mayTags varEnv valuation cond2
+  end
+
+let feasible mayTags prod cond =
+  let varEnv = prodVarEnv prod in
+  let atoms =
+    []
+    |> collectPossibleAtoms mayTags varEnv cond
+    |> collectPossibleAtoms mayTags varEnv prod.unless
+  in
+  {# Tag conditions are expected to be small. #}
+  allValuations atoms
+  |> List.exists
+      (fn (valuation : Valuation) =>
+        evalCond mayTags varEnv valuation cond
+        && not (evalCond mayTags varEnv valuation prod.unless))
+
+let stepTag ntId prod (mayTags, changed) (tag, cond) =
+  if feasible mayTags prod cond then
+    (let (mayTags, tagAdded) = addMayTag mayTags ntId tag in
+    (mayTags, changed || tagAdded))
+  else
+    (mayTags, changed)
+
+let stepProd ntId state prod =
+  List.foldLeft (stepTag ntId prod) state prod.tags
+
+let stepNTerm state (nt : NTerm) =
+  List.foldLeft (stepProd nt.id) state nt.prods
+
+let step nterms mayTags =
+  List.foldLeft stepNTerm (mayTags, False) nterms
+
+let rec fixpoint nterms mayTags =
+  let (mayTags, changed) = step nterms mayTags in
+  if changed then
+    fixpoint nterms mayTags
+  else
+    mayTags
+
+let filterTags mayTags prod =
+  List.filter
+    (fn ((_, cond) : Pair Tag (TagCond Var)) =>
+      feasible mayTags prod cond)
+    prod.tags
+
+let rewriteProd mayTags prod =
+  let (NTermProd {module Prod}) = prod in
+  NTermProd { module Prod, tags = filterTags mayTags prod }
+
+let rewriteNTerm mayTags (NTerm {module NT}) =
+  NTerm
+    { module NT
+    , prods = List.map (rewriteProd mayTags) NT.prods
+    }
 
 {## Eliminate dead tags from non-terminals. ##}
-pub let transform (g : RichGrammar) : RichGrammar =
-  # TODO: Implement this function.
-  g
+pub let transform (RichGrammar {module G}) : RichGrammar =
+  let mayTags = fixpoint G.nterms (initMayTags G.nterms) in
+  RichGrammar
+    { module G
+    , nterms = List.map (rewriteNTerm mayTags) G.nterms
+    }

test.sh

@@ -0,0 +1,72 @@
+#!/usr/bin/env bash
+set -u
+
+if [ $# -ne 1 ]; then
+	echo "USAGE: ./test.sh TEST_SUITE"
+	exit 1
+fi
+
+if [ ! -f "$1" ]; then
+	echo "ERROR: test suite file not found: $1"
+	exit 1
+fi
+
+if [ ! -r "$1" ]; then
+	echo "ERROR: test suite file is not readable: $1"
+	exit 1
+fi
+
+binary="${DBL:-dbl}"
+if ! command -v "$binary" > /dev/null; then
+	echo "ERROR: dbl executable not found in PATH"
+	exit 1
+fi
+
+if [ -z "${DBL_LIB:-}" ]; then
+	dbl_path=$(command -v "$binary")
+	dbl_prefix=$(dirname "$(dirname "$dbl_path")")
+	if [ -d "$dbl_prefix/lib/dbl/stdlib" ]; then
+		export DBL_LIB="$dbl_prefix/lib/dbl/stdlib"
+	else
+		echo "ERROR: DBL_LIB is not set and DBL stdlib was not found next to '$dbl_path'"
+		exit 1
+	fi
+fi
+
+flags=""
+total_tests=0
+passed_tests=0
+
+function simple_test {
+	total_tests=$((total_tests + 1))
+
+	local file="$1"
+	local cmd=("$binary")
+	if [ -n "$flags" ]; then
+		# shellcheck disable=SC2206
+		cmd+=($flags)
+	fi
+	cmd+=("$file")
+
+	echo "${cmd[*]}"
+	if "${cmd[@]}"; then
+		passed_tests=$((passed_tests + 1))
+	else
+		echo "Test file failed: $file"
+	fi
+}
+
+function run_with_flags {
+	local flags="$2"
+	"$1"
+}
+
+source "$1"
+
+echo "Passed: ${passed_tests}/${total_tests}"
+
+if [ "$passed_tests" -eq "$total_tests" ]; then
+	exit 0
+else
+	exit 1
+fi

test/TestAll.fram

@@ -0,0 +1 @@
+import TransformTests/DeadNTermTagsElim