Implement SplitNTermLevels transform with tests

src/Repr/Common/Level.fram

@@ -14,3 +14,37 @@ pub data Level =
 
   {## The highest precedence level. ##}
   | LTop
+
+{## Equality of levels. ##}
+pub method equal (l1 : Level) (l2 : Level) =
+  match l1, l2 with
+  | LBot,    LBot    => True
+  | LBot,    _       => False
+  | LTop,    LTop    => True
+  | LTop,    _       => False
+  | LNum n1, LNum n2 => n1 == n2
+  | LNum _,  _       => False
+  end
+
+{## Strict order on levels. ##}
+pub method lt (l1 : Level) (l2 : Level) =
+  match l1, l2 with
+  | LBot,    LBot    => False
+  | LBot,    _       => True
+  | _,       LBot    => False
+  | LTop,    _       => False
+  | _,       LTop    => True
+  | LNum n1, LNum n2 => n1 < n2
+  end
+
+{## Non-strict order on levels. ##}
+pub method le (l1 : Level) (l2 : Level) =
+  l1 == l2 || l1 < l2
+
+{## Convert level to string. ##}
+pub method toString (level : Level) =
+  match level with
+  | LBot => "bot"
+  | LTop => "top"
+  | LNum n => n.toString
+  end

src/Transform/SplitNTermLevels.fram

@@ -9,8 +9,189 @@ of the original non-terminal. Such non-terminals contain only productions of
 the corresponding level and a single production that calls the next level. ##}
 
 import open Repr/RichGrammar
+import List
+import Map
+import Utils/UID
+
+let (Map { module LevelMap }) = Map.make { Key = Level }
+let (Map { module TagMap }) = Map.make { Key = String }
+
+type LevelSet = LevelMap.T Unit
+type TagSet = TagMap.T Unit
+
+let collectLevels (prods : List NTermProd) =
+  let levelSet =
+    List.foldLeft
+      (fn (levelSet : LevelSet) (prod : NTermProd) =>
+        levelSet.add prod.level ())
+      LevelMap.empty
+      prods
+  in
+  levelSet.fold (fn {key} _ levels => key :: levels) [] >.rev
+
+let levelProds (level : Level) (prods : List NTermProd) =
+  List.filter
+    (fn (prod : NTermProd) => prod.level == level)
+    prods
+
+type ProdsByLevel = LevelMap.T (List NTermProd)
+
+let addProdToLevel (prodsByLevel : ProdsByLevel) (prod : NTermProd) =
+  let prods =
+    prodsByLevel.find prod.level >.unwrapOr []
+  in
+  prodsByLevel.add prod.level (prod :: prods)
+
+let prodsByLevel prods =
+  List.foldLeft addProdToLevel LevelMap.empty prods
+  >.map (fn {key} prods => prods.rev)
+
+let lookupProds (level : Level) (prodsByLevel : ProdsByLevel) =
+  prodsByLevel.findErr
+    {~onError = fn _ => impossible ()}
+    level
+
+type LevelIds = List (Pair Level NTermId)
+type NTermLevelIds = Pair String LevelIds
+type IdTable = NTermMap.T NTermLevelIds
+
+parameter ~onError
+
+let lookupNTermLevelIds (idTable : IdTable) (id : NTermId) =
+  idTable.findErr
+    {~onError = fn _ => impossible ()}
+    id
+
+let lookupLevelIds idTable id =
+  snd (lookupNTermLevelIds idTable id)
+
+let invalidLevelError (ntName : String) (level : Level) =
+  "Requested level " + level.toString +
+  " for non-terminal " + ntName +
+  " is stronger than every production level"
+
+let rec pickLevelId ntName (level : Level) (levelIds : LevelIds) =
+  match levelIds with
+  | [] => impossible ()
+  | (level', id) :: [] =>
+    if level <= level' then id else ~onError (invalidLevelError ntName level)
+  | (level', id) :: rest =>
+    if level <= level' then id else pickLevelId ntName level rest
+  end
+
+let lookupNTermId (idTable : IdTable) id level =
+  let (ntName, levelIds) = lookupNTermLevelIds idTable id in
+  pickLevelId ntName level levelIds
+
+let rewriteSymbol (idTable : IdTable) sym =
+  match sym with
+  | PS_Token _ => sym
+  | PS_NTerm {var, level} id =>
+    PS_NTerm {var, level} (lookupNTermId idTable id level)
+  end
+
+let rewriteProd (idTable : IdTable) (NTermProd {module Prod}) =
+  NTermProd
+    { module Prod
+    , symbols = List.map (rewriteSymbol idTable) Prod.symbols
+    }
+
+let collectTags (tags : List Tag) =
+  let tagSet =
+    List.foldLeft
+      (fn (tagSet : TagSet) tag => tagSet.add tag ())
+      TagMap.empty
+      tags
+  in
+  tagSet.fold (fn {key} _ tags => key :: tags) [] >.rev
+
+let tagsForLevels var levels prodsByLevel =
+  levels
+  |> List.concatMap
+      (fn level =>
+        lookupProds level prodsByLevel
+        |> List.concatMap (fn (prod : NTermProd) => prod.tags))
+  |> List.map (fn ((tag, _) : Pair Tag (TagCond Var)) => tag)
+  |> collectTags
+  |> List.map (fn tag => (tag, TC_Tag tag var))
+
+let forwardVar (nt : NTerm) =
+  Var {id = UID.fresh (), name = None, typ = nt.valueType}
+
+let forwardProd (nt : NTerm) level nextLevel nextId tagLevels prodsByLevel =
+  let var = forwardVar nt in
+  NTermProd
+    { symbols =
+        [PS_NTerm {var, level = nextLevel} nextId]
+    , level
+    , tags = tagsForLevels var tagLevels prodsByLevel
+    , unless = TC_False
+    , action = AForward
+    }
+
+let splitNTermName (nt : NTerm) (id : NTermId) (level : Level) =
+  if id == nt.id then nt.name else nt.name + "@" + level.toString
+
+let rec splitLevels
+    (idTable : IdTable)
+    (nt : NTerm)
+    (prodsByLevel : ProdsByLevel)
+    (levelIds : LevelIds) =
+  match levelIds with
+  | [] => []
+  | (level, id) :: rest =>
+    let prods =
+      lookupProds level prodsByLevel
+      |> List.map (rewriteProd idTable)
+    let prods =
+      match rest with
+      | [] => prods
+      | (nextLevel, nextId) :: _ =>
+        prods +
+          [forwardProd
+            nt level nextLevel nextId (List.map fst rest) prodsByLevel]
+      end
+    in
+    NTerm
+      { id
+      , name = splitNTermName nt id level
+      , valueType = nt.valueType
+      , prods
+      } :: splitLevels idTable nt prodsByLevel rest
+  end
+
+let splitNTerm (idTable : IdTable) (nt : NTerm) =
+  match lookupLevelIds idTable nt.id with
+  | [] => [nt]
+  | levelIds =>
+    let prodsByLevel = prodsByLevel nt.prods in
+    splitLevels idTable nt prodsByLevel levelIds
+  end
+
+let freshLevelIds (nt : NTerm) levels =
+  match levels with
+  | [] => []
+  | level :: levels =>
+    (level, nt.id) ::
+      List.map (fn level => (level, NTermId.fresh ())) levels
+  end
+
+let addNTermLevelIds (idTable : IdTable) (nt : NTerm) =
+  idTable.add nt.id (nt.name, freshLevelIds nt (collectLevels nt.prods))
+
+pub let transformErr (RichGrammar {module G}) : RichGrammar =
+  let idTable =
+    List.foldLeft addNTermLevelIds NTermMap.empty G.nterms
+  in
+  RichGrammar
+    { module G
+    , nterms =
+        G.nterms
+        |> List.concatMap (splitNTerm idTable)
+    }
 
 {## Split each non-terminal into multiple levels. ##}
-pub let transform (g : RichGrammar) : RichGrammar =
-  # TODO: Implement this function.
-  g
+pub let transform g : RichGrammar =
+  transformErr
+    {~onError = fn msg => runtimeError ("SplitNTermLevels: " + msg)}
+    g

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/SplitNTermLevels