Tests

10 files changed, 560 insertions, 11 deletions

diff --git a/.gitignore b/.gitignore
index 44475cab1..b0a210bf5 100644
--- a/.gitignore
+++ b/.gitignore
@@ -84,3 +84,6 @@ result
 profile/
 .stack-work-profile/
 .stack-work-profile-pre-pmcfg/
+.stack-work-pmcfg-test/
+.stack-work-pmcfg-test-pre/
+.stack-work-pmcfg-test-hooks/
diff --git a/Makefile b/Makefile
index 3cc5f8377..140a1b4cd 100644
--- a/Makefile
+++ b/Makefile
@@ -1,6 +1,7 @@
 .PHONY: all build install doc clean html deb pkg bintar sdist
 .PHONY: profile-build profile-rgl-time profile-rgl-memory profile-rgl-clean
 .PHONY: bench-build bench-rgl bench-rgl-pre-pmcfg bench-rgl-clean
+.PHONY: test-pmcfg test-pmcfg-core test-pmcfg-equivalence test-pmcfg-rgl-equivalence test-pmcfg-clean
 
 # This gets the numeric part of the version from the cabal file
 VERSION=$(shell sed -ne "s/^version: *\([0-9.]*\).*/\1/p" gf.cabal)
@@ -65,6 +66,19 @@ RGL_BENCH_PRE_PMCFG_NAME ?= RGLBenchPrePmcfg
 BENCH_RTS_OPTIONS ?= +RTS -T -RTS
 BENCH_STACK = stack --stack-yaml $(CURDIR)/stack.yaml --work-dir $(BENCH_STACK_WORK)
 
+PMCFG_TEST_CORE_STACK_WORK ?= .stack-work-pmcfg-test-hooks
+PMCFG_TEST_STACK_WORK ?= .stack-work-pmcfg-test
+PMCFG_TEST_PRE_STACK_WORK ?= .stack-work-pmcfg-test-pre
+PMCFG_TEST_DIR ?= $(PROFILE_DIR)/pmcfg-test
+PMCFG_EQ_DIR ?= $(PMCFG_TEST_DIR)/equivalence
+PMCFG_EQ_NAME ?= PMCFGEquiv
+PMCFG_TEST_IMPORT_DIRS ?= testsuite/canonical/grammars
+PMCFG_TEST_IMPORT_OPTIONS = $(foreach dir,$(PMCFG_TEST_IMPORT_DIRS),-i $(dir))
+PMCFG_TEST_MODULES ?= testsuite/pmcfg/fixtures/PmcfgDiffCnc.gf testsuite/compiler/params/paramsCnc.gf testsuite/runtime/parser/LiteralsCnc.gf testsuite/runtime/parser/DummyNatCnc.gf testsuite/runtime/linearize/TestCnc.gf testsuite/compiler/check/lins/linsCnc.gf testsuite/canonical/gold/FoodsFin.gf
+PMCFG_TEST_GF_OPTIONS ?= --make --quiet --src $(PMCFG_TEST_IMPORT_OPTIONS)
+RGL_PMCFG_TEST_MODULES ?= $(RGL_DIR)/src/german/LangGer.gf $(RGL_DIR)/src/finnish/LangFin.gf $(RGL_DIR)/src/swedish/LangSwe.gf
+RGL_PMCFG_TEST_GF_OPTIONS ?= --make --quiet --src --preproc=mkPresent $(RGL_PROFILE_IMPORT_OPTIONS)
+
 all: build
 
 dist/setup-config: gf.cabal Setup.hs WebSetup.hs
@@ -122,6 +136,42 @@ bench-rgl-pre-pmcfg:
 bench-rgl-clean:
 	rm -rf $(RGL_BENCH_DIR) $(RGL_BENCH_PRE_PMCFG_DIR)
 
+test-pmcfg: test-pmcfg-core test-pmcfg-equivalence
+
+test-pmcfg-core:
+	stack --work-dir $(PMCFG_TEST_CORE_STACK_WORK) test gf:pmcfg-tests --flag gf:pmcfg-test-hooks
+
+test-pmcfg-equivalence:
+	stack --work-dir $(PMCFG_TEST_STACK_WORK) build
+	stack --work-dir $(PMCFG_TEST_PRE_STACK_WORK) build --flag gf:pre-pmcfg
+	rm -rf $(PMCFG_EQ_DIR)
+	mkdir -p $(PMCFG_EQ_DIR)
+	@set -e; \
+	i=0; \
+	for module in $(PMCFG_TEST_MODULES); do \
+	  i=$$((i+1)); \
+	  case_name=$$(basename "$$module" .gf); \
+	  case_dir="$(PMCFG_EQ_DIR)/$$i-$$case_name"; \
+	  new_gfo="$$case_dir/new-gfo"; \
+	  new_pgf="$$case_dir/new-pgf"; \
+	  pre_gfo="$$case_dir/pre-gfo"; \
+	  pre_pgf="$$case_dir/pre-pgf"; \
+	  mkdir -p "$$new_gfo" "$$new_pgf" "$$pre_gfo" "$$pre_pgf"; \
+	  echo "PMCFG equivalence: $$module"; \
+	  stack --work-dir $(PMCFG_TEST_STACK_WORK) exec gf -- $(PMCFG_TEST_GF_OPTIONS) --gfo-dir="$$new_gfo" --output-dir="$$new_pgf" --name=$(PMCFG_EQ_NAME) "$$module"; \
+	  stack --work-dir $(PMCFG_TEST_PRE_STACK_WORK) exec gf -- $(PMCFG_TEST_GF_OPTIONS) --gfo-dir="$$pre_gfo" --output-dir="$$pre_pgf" --name=$(PMCFG_EQ_NAME) "$$module"; \
+	  test -f "$$new_pgf/$(PMCFG_EQ_NAME).pgf"; \
+	  test -f "$$pre_pgf/$(PMCFG_EQ_NAME).pgf"; \
+	  cmp "$$new_pgf/$(PMCFG_EQ_NAME).pgf" "$$pre_pgf/$(PMCFG_EQ_NAME).pgf" || { echo "PMCFG output differs for $$module; artifacts kept in $$case_dir"; exit 1; }; \
+	done
+
+test-pmcfg-rgl-equivalence:
+	@test -d "$(RGL_DIR)" || { echo "Missing RGL_DIR: $(RGL_DIR)"; exit 1; }
+	$(MAKE) test-pmcfg-equivalence PMCFG_TEST_MODULES="$(RGL_PMCFG_TEST_MODULES)" PMCFG_TEST_GF_OPTIONS="$(RGL_PMCFG_TEST_GF_OPTIONS)" PMCFG_EQ_DIR="$(PMCFG_TEST_DIR)/rgl-equivalence"
+
+test-pmcfg-clean:
+	rm -rf $(PMCFG_TEST_DIR)
+
 install:
 ifeq ($(STACK),1)
 	stack install
diff --git a/gf.cabal b/gf.cabal
index a19772a57..05a1c4f91 100644
--- a/gf.cabal
+++ b/gf.cabal
@@ -73,6 +73,11 @@ flag pre-pmcfg
   Default: False
   Manual: True
 
+flag pmcfg-test-hooks
+  Description: Expose test-only PMCFG differential hooks
+  Default: False
+  Manual: True
+
 library
   default-language: Haskell2010
   build-depends:
@@ -301,6 +306,14 @@ library
     other-modules:
       GF.Compile.GeneratePmcfgPre
 
+  if flag(pmcfg-test-hooks)
+    cpp-options: -DPMCFG_TEST_HOOKS
+    exposed-modules:
+      GF.Compile.PMCFGTestHooks
+    other-modules:
+      GF.Compile.PMCFGTestTypes
+      GF.Compile.GeneratePmcfgPre
+
   if flag(server)
     build-depends:
       cgi >= 3001.3.0.2 && < 3001.6,
@@ -432,3 +445,15 @@ test-suite gf-tests
     process >= 1.4.3 && < 1.7
   build-tool-depends: gf:gf
   default-language: Haskell2010
+
+test-suite pmcfg-tests
+  type: exitcode-stdio-1.0
+  main-is: run.hs
+  hs-source-dirs: testsuite/pmcfg
+  build-depends:
+    base >= 4.9.1 && < 4.22,
+    gf
+  default-language: Haskell2010
+
+  if !flag(pmcfg-test-hooks)
+    buildable: False
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index e483911d1..ae1ea08ea 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
+{-# LANGUAGE BangPatterns, CPP, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
 ----------------------------------------------------------------------
 -- |
 -- Maintainer  : Krasimir Angelov
@@ -10,7 +10,13 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.GeneratePMCFG
-    (generatePMCFG, pgfCncCat, addPMCFG, resourceValues
+    ( generatePMCFG, pgfCncCat, addPMCFG, resourceValues
+#ifdef PMCFG_TEST_HOOKS
+    , pmcfgTestGetFIds
+    , pmcfgTestGetFIdsCached
+    , pmcfgTestGetSingleFId
+    , pmcfgTestBuildPMCFG
+#endif
     ) where
 
 --import PGF.CId
@@ -26,23 +32,21 @@ import GF.Data.Operations
 import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE,
 import GF.Data.Utilities (updateNthM) --updateNth
 import GF.Compile.Compute.Concrete(normalForm,resourceValues)
+#ifdef PMCFG_TEST_HOOKS
+import GF.Compile.PMCFGTestTypes
+#endif
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.List as List
---import qualified Data.IntMap as IntMap
 import qualified Data.IntSet as IntSet
 import GF.Text.Pretty
 import Data.Array.IArray
 import Data.Array.Unboxed
 import Data.Array.ST
---import Data.Maybe
---import Data.Char (isDigit)
 import Control.Applicative(Applicative(..))
 import Control.Monad
 import Control.Monad.ST (ST)
 import Control.Monad.Identity
---import Control.Exception
---import Debug.Trace(trace)
 import qualified Control.Monad.Fail as Fail
 
 ----------------------------------------------------------------------
@@ -314,6 +318,38 @@ getFIdAlts = fIdAltsFromKey . fIdKey
 getSingleFId :: ProtoFCat -> FId
 getSingleFId = expectSingleFId "getSingleFId" . getFIdAlts
 
+#ifdef PMCFG_TEST_HOOKS
+pmcfgTestGetFIds :: TestSchema -> [FId]
+pmcfgTestGetFIds = getFIds . testProtoFCat
+
+pmcfgTestGetFIdsCached :: TestSchema -> ([FId], [FId])
+pmcfgTestGetFIdsCached schema =
+  let pcat          = testProtoFCat schema
+      !(env1,alts1) = getFIdAltsCached emptyPMCFGEnv pcat
+      !(_,alts2)    = getFIdAltsCached env1 pcat
+  in (fidAltsToList alts1, fidAltsToList alts2)
+
+pmcfgTestGetSingleFId :: TestSchema -> FId
+pmcfgTestGetSingleFId = getSingleFId . testProtoFCat
+
+testProtoFCat :: TestSchema -> ProtoFCat
+testProtoFCat schema =
+  PFCat (identS "Test") 1 (testSchema schema)
+
+testSchema :: TestSchema -> Schema Identity Int (Int,[(Term,Int)])
+testSchema (TestRec schemas) =
+  CRec [(LIdent (rawIdentS ("r"++show i)), Identity (testSchema schema))
+       | (i,schema) <- zip [0..] schemas]
+testSchema (TestTbl schemas) =
+  CTbl (Sort (identS "TestParam"))
+       [(EInt i, Identity (testSchema schema))
+       | (i,schema) <- zip [0..] schemas]
+testSchema TestStr =
+  CStr 0
+testSchema (TestPar m choices) =
+  CPar (m, [(EInt choice, choice) | choice <- choices])
+#endif
+
 fIdKey :: ProtoFCat -> FIdKey
 fIdKey (PFCat _ _ schema) =
   FIdKey (collect schema)
@@ -613,6 +649,18 @@ getPMCFG (PMCFGEnv prodGroups funSet _) =
                     Just argSets -> argSets
                     Nothing      -> rectangleArgSets rectangles
 
+#ifdef PMCFG_TEST_HOOKS
+pmcfgTestBuildPMCFG :: [TestProduction] -> PMCFG
+pmcfgTestBuildPMCFG =
+  getPMCFG . List.foldl' addTestProduction emptyPMCFGEnv
+  where
+    addTestProduction env (TestProduction fid seqs args) =
+      addFunction env fid (mkArray seqs) (Rectangle (mapStrict fIdAltsFromList args))
+
+    fIdAltsFromList :: [FId] -> FIdAlts
+    fIdAltsFromList fids = FIdAlts (listArray (0,length fids-1) fids)
+#endif
+
 insertProduction :: FId -> FunId -> Rectangle -> ProdGroups -> ProdGroups
 insertProduction !fid !funid rect prodGroups =
   Map.insert (fid,funid) group' prodGroups
diff --git a/src/compiler/GF/Compile/GeneratePmcfgPre.hs b/src/compiler/GF/Compile/GeneratePmcfgPre.hs
index 749cb0696..770fa8207 100644
--- a/src/compiler/GF/Compile/GeneratePmcfgPre.hs
+++ b/src/compiler/GF/Compile/GeneratePmcfgPre.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
+{-# LANGUAGE BangPatterns, CPP, RankNTypes, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}
 ----------------------------------------------------------------------
 -- |
 -- Maintainer  : Krasimir Angelov
@@ -10,7 +10,12 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.GeneratePmcfgPre
-    (generatePMCFG, pgfCncCat, addPMCFG, resourceValues
+    ( generatePMCFG, pgfCncCat, addPMCFG, resourceValues
+#ifdef PMCFG_TEST_HOOKS
+    , pmcfgTestGetFIds
+    , pmcfgTestGetSingleFId
+    , pmcfgTestBuildPMCFG
+#endif
     ) where
 
 --import PGF.CId
@@ -26,6 +31,9 @@ import GF.Data.Operations
 import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE,
 import GF.Data.Utilities (updateNthM) --updateNth
 import GF.Compile.Compute.Concrete(normalForm,resourceValues)
+#ifdef PMCFG_TEST_HOOKS
+import GF.Compile.PMCFGTestTypes
+#endif
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.List as List
@@ -311,6 +319,33 @@ getFIds (PFCat _ _ schema) =
     variants (CPar (m,values)) = do (value,index) <- member values
                                     return (m*index)
 
+#ifdef PMCFG_TEST_HOOKS
+pmcfgTestGetFIds :: TestSchema -> [FId]
+pmcfgTestGetFIds = getFIds . testProtoFCat
+
+pmcfgTestGetSingleFId :: TestSchema -> FId
+pmcfgTestGetSingleFId schema =
+  let [fid] = getFIds (testProtoFCat schema)
+  in fid
+
+testProtoFCat :: TestSchema -> ProtoFCat
+testProtoFCat schema =
+  PFCat (identS "Test") 1 (testSchema schema)
+
+testSchema :: TestSchema -> Schema Identity Int (Int,[(Term,Int)])
+testSchema (TestRec schemas) =
+  CRec [(LIdent (rawIdentS ("r"++show i)), Identity (testSchema schema))
+       | (i,schema) <- zip [0..] schemas]
+testSchema (TestTbl schemas) =
+  CTbl (Sort (identS "TestParam"))
+       [(EInt i, Identity (testSchema schema))
+       | (i,schema) <- zip [0..] schemas]
+testSchema TestStr =
+  CStr 0
+testSchema (TestPar m choices) =
+  CPar (m, [(EInt choice, choice) | choice <- choices])
+#endif
+
 catFactor :: ProtoFCat -> Int
 catFactor (PFCat _ f _) = f
 
@@ -534,8 +569,8 @@ evalTerm path (V pt ts)    =
          do vs <- getAllParamValues pt
             case lookup trm (zip vs ts) of
               Just t  -> evalTerm path t
-              Nothing -> ppbug $ "evalTerm: missing value:"<+>trm
-                                 $$ "among:" <+>fsep (map (ppU 10) vs)
+              Nothing -> ppbug $ "evalTerm: missing value:" <+> trm
+                                 $$ "among:" <+> fsep (map (ppU 10) vs)
 evalTerm path (S term sel) = do v <- evalTerm CNil sel
                                 evalTerm (CSel v path) term
 evalTerm path (FV terms)   = variants terms >>= evalTerm path
@@ -580,6 +615,15 @@ getPMCFG (PMCFGEnv prodSet funSet) =
             count = sum (map (product . map length) xs)
             ys    = foldl (zipWith (foldr IntSet.insert)) (repeat IntSet.empty) xs
 
+#ifdef PMCFG_TEST_HOOKS
+pmcfgTestBuildPMCFG :: [TestProduction] -> PMCFG
+pmcfgTestBuildPMCFG =
+  getPMCFG . List.foldl' addTestProduction emptyPMCFGEnv
+  where
+    addTestProduction env (TestProduction fid seqs args) =
+      addFunction env fid (mkArray seqs) args
+#endif
+
 ------------------------------------------------------------
 -- updating the MCF rule
 
diff --git a/src/compiler/GF/Compile/PMCFGTestHooks.hs b/src/compiler/GF/Compile/PMCFGTestHooks.hs
new file mode 100644
index 000000000..e8014107e
--- /dev/null
+++ b/src/compiler/GF/Compile/PMCFGTestHooks.hs
@@ -0,0 +1,43 @@
+module GF.Compile.PMCFGTestHooks
+  ( TestSchema(..)
+  , TestProduction(..)
+  , PMCFGResults(..)
+  , getFIdsPre
+  , getFIdsOptimized
+  , getFIdsOptimizedCached
+  , getSingleFIdPre
+  , getSingleFIdOptimized
+  , pmcfgResults
+  ) where
+
+import GF.Compile.PMCFGTestTypes
+import GF.Grammar (FId, PMCFG)
+import qualified GF.Compile.GeneratePMCFG as Optimized
+import qualified GF.Compile.GeneratePmcfgPre as Pre
+
+data PMCFGResults = PMCFGResults
+  { pmcfgPre       :: PMCFG
+  , pmcfgOptimized :: PMCFG
+  } deriving (Eq, Show)
+
+getFIdsPre :: TestSchema -> [FId]
+getFIdsPre = Pre.pmcfgTestGetFIds
+
+getFIdsOptimized :: TestSchema -> [FId]
+getFIdsOptimized = Optimized.pmcfgTestGetFIds
+
+getFIdsOptimizedCached :: TestSchema -> ([FId], [FId])
+getFIdsOptimizedCached = Optimized.pmcfgTestGetFIdsCached
+
+getSingleFIdPre :: TestSchema -> FId
+getSingleFIdPre = Pre.pmcfgTestGetSingleFId
+
+getSingleFIdOptimized :: TestSchema -> FId
+getSingleFIdOptimized = Optimized.pmcfgTestGetSingleFId
+
+pmcfgResults :: [TestProduction] -> PMCFGResults
+pmcfgResults prods =
+  PMCFGResults
+    { pmcfgPre       = Pre.pmcfgTestBuildPMCFG prods
+    , pmcfgOptimized = Optimized.pmcfgTestBuildPMCFG prods
+    }
diff --git a/src/compiler/GF/Compile/PMCFGTestTypes.hs b/src/compiler/GF/Compile/PMCFGTestTypes.hs
new file mode 100644
index 000000000..1ea8bf626
--- /dev/null
+++ b/src/compiler/GF/Compile/PMCFGTestTypes.hs
@@ -0,0 +1,17 @@
+module GF.Compile.PMCFGTestTypes
+  ( TestSchema(..)
+  , TestProduction(..)
+  ) where
+
+import GF.Grammar (FId, SeqId)
+
+data TestSchema
+  = TestRec [TestSchema]
+  | TestTbl [TestSchema]
+  | TestStr
+  | TestPar Int [Int]
+  deriving (Eq, Show)
+
+data TestProduction =
+  TestProduction !FId [SeqId] [[FId]]
+  deriving (Eq, Show)
diff --git a/testsuite/pmcfg/fixtures/PmcfgDiff.gf b/testsuite/pmcfg/fixtures/PmcfgDiff.gf
new file mode 100644
index 000000000..3ea7b3cae
--- /dev/null
+++ b/testsuite/pmcfg/fixtures/PmcfgDiff.gf
@@ -0,0 +1,11 @@
+abstract PmcfgDiff = {
+cat
+  S ;
+  NP ;
+
+fun
+  Use : NP -> S ;
+  Pair : NP -> NP -> S ;
+  One : NP ;
+  Two : NP ;
+}
diff --git a/testsuite/pmcfg/fixtures/PmcfgDiffCnc.gf b/testsuite/pmcfg/fixtures/PmcfgDiffCnc.gf
new file mode 100644
index 000000000..4bbafa174
--- /dev/null
+++ b/testsuite/pmcfg/fixtures/PmcfgDiffCnc.gf
@@ -0,0 +1,40 @@
+concrete PmcfgDiffCnc of PmcfgDiff = {
+param
+  Number = Sg | Pl ;
+  Person = P1 | P2 ;
+  Case = Nom | Acc | Poss Number Person ;
+
+lincat
+  S = {s : Str} ;
+  NP = {s : Case => Str ; n : Number ; p : Person} ;
+
+lin
+  Use np = {s = np.s ! Poss np.n np.p} ;
+  Pair x y = {s = x.s ! Nom ++ y.s ! Acc} ;
+
+  One = {
+    s = table {
+      Nom => "one" ;
+      Acc => "one-acc" ;
+      Poss Sg P1 => "one-sg-p1" ;
+      Poss Sg P2 => "one-sg-p2" ;
+      Poss Pl P1 => "one-pl-p1" ;
+      Poss Pl P2 => "one-pl-p2"
+    } ;
+    n = Sg ;
+    p = P1
+  } ;
+
+  Two = {
+    s = table {
+      Nom => "two" ;
+      Acc => "two-acc" ;
+      Poss Sg P1 => "two-sg-p1" ;
+      Poss Sg P2 => "two-sg-p2" ;
+      Poss Pl P1 => "two-pl-p1" ;
+      Poss Pl P2 => "two-pl-p2"
+    } ;
+    n = Pl ;
+    p = P2
+  } ;
+}
diff --git a/testsuite/pmcfg/run.hs b/testsuite/pmcfg/run.hs
new file mode 100644
index 000000000..1a110d3c4
--- /dev/null
+++ b/testsuite/pmcfg/run.hs
@@ -0,0 +1,268 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Main where
+
+import GF.Compile.PMCFGTestHooks
+
+import Control.Exception (SomeException, evaluate, try)
+import Control.Monad (unless)
+import Data.List (nub)
+import System.Exit (exitFailure)
+
+data Test = Test String (IO (Either String ()))
+
+main :: IO ()
+main = do
+  let tests = enumerationTests ++ singletonTests ++ finalizerTests
+  results <- mapM runTest tests
+  let failures = [(name,msg) | (name,Left msg) <- results]
+  unless (null failures) $ do
+    putStrLn ""
+    putStrLn (show (length failures) ++ " PMCFG differential test(s) failed")
+    mapM_ printFailure failures
+    exitFailure
+
+runTest :: Test -> IO (String, Either String ())
+runTest (Test name action) = do
+  result <- action
+  putStrLn (name ++ ": " ++ either (const "FAIL") (const "OK") result)
+  return (name,result)
+
+printFailure :: (String, String) -> IO ()
+printFailure (name,msg) = do
+  putStrLn ("--- " ++ name)
+  putStrLn msg
+
+enumerationTests :: [Test]
+enumerationTests =
+  [ enumCase "no parameters" TestStr
+  , enumCase "one parameter" (TestPar 1 [0,1,2])
+  , enumCase "multiple parameters" (TestRec [TestPar 1 [0,1], TestPar 2 [0,1]])
+  , enumCase "record nesting" (TestRec [TestStr, TestRec [TestPar 3 [0,1], TestPar 9 [0,1]]])
+  , enumCase "table nesting" (TestTbl [TestPar 1 [0,1], TestRec [TestStr, TestPar 4 [0,1]]])
+  , enumCase "restricted singleton" (TestPar 3 [2])
+  , enumCase "mixed singleton and multi-choice" (TestRec [TestPar 1 [0], TestPar 10 [0,1,2]])
+  , enumCase "duplicate weighted choices" (TestRec [TestPar 2 [0,0,1], TestPar 1 [0,1]])
+  , enumCorpusCase "generated small schema corpus" generatedSchemas
+  ]
+
+enumCase :: String -> TestSchema -> Test
+enumCase name schema =
+  Test ("getFIds/" ++ name) (return (compareSchema schema))
+
+enumCorpusCase :: String -> [TestSchema] -> Test
+enumCorpusCase name schemas =
+  Test ("getFIds/" ++ name) $
+    return $
+      case [(schema,msg) | schema <- schemas, Left msg <- [compareSchema schema]] of
+        [] -> Right ()
+        failures ->
+          Left $
+            unlines $
+              ("checked: " ++ show (length schemas) ++ " schemas")
+              : concatMap describeFailure (take 5 failures)
+  where
+    describeFailure (schema,msg) =
+      [ "schema: " ++ show schema
+      , msg
+      ]
+
+compareSchema :: TestSchema -> Either String ()
+compareSchema schema =
+  let pre = getFIdsPre schema
+      optimized = getFIdsOptimized schema
+      (cached1,cached2) = getFIdsOptimizedCached schema
+  in if pre == optimized && pre == cached1 && pre == cached2
+       then Right ()
+       else Left $
+         unlines [ "schema:    " ++ show schema
+                 , "pre:       " ++ show pre
+                 , "optimized: " ++ show optimized
+                 , "cached #1: " ++ show cached1
+                 , "cached #2: " ++ show cached2
+                 ]
+
+singletonTests :: [Test]
+singletonTests =
+  [ singleCase "no-parameter singleton" TestStr
+  , singleCase "restricted singleton" (TestRec [TestPar 3 [2], TestStr])
+  , singleFailureCase "non-singleton result" (TestPar 1 [0,1])
+  , singleFailureCase "nested non-singleton result" (TestRec [TestPar 1 [0], TestPar 4 [0,1]])
+  ]
+
+singleCase :: String -> TestSchema -> Test
+singleCase name schema =
+  Test ("getSingleFId/" ++ name) $
+    return $
+      let pre = getSingleFIdPre schema
+          optimized = getSingleFIdOptimized schema
+      in if pre == optimized
+           then Right ()
+           else Left $
+             unlines [ "schema:    " ++ show schema
+                     , "pre:       " ++ show pre
+                     , "optimized: " ++ show optimized
+                     ]
+
+singleFailureCase :: String -> TestSchema -> Test
+singleFailureCase name schema =
+  Test ("getSingleFId/" ++ name) $ do
+    pre <- throws (getSingleFIdPre schema)
+    optimized <- throws (getSingleFIdOptimized schema)
+    return $
+      if pre && optimized
+        then Right ()
+        else Left $
+          unlines [ "schema:           " ++ show schema
+                  , "pre threw:        " ++ show pre
+                  , "optimized threw:  " ++ show optimized
+                  ]
+
+throws :: a -> IO Bool
+throws value = do
+  result <- try (evaluate value)
+  return $ case result of
+    Left (_ :: SomeException) -> True
+    Right _                  -> False
+
+finalizerTests :: [Test]
+finalizerTests =
+  [ pmcfgCase "duplicate rectangles are ignored"
+      [ TestProduction 0 [1,2] [[10],[20]]
+      , TestProduction 0 [1,2] [[10],[20]]
+      ]
+  , pmcfgCase "complete products are compressed"
+      [ TestProduction 0 [1] [[1],[10]]
+      , TestProduction 0 [1] [[1],[20]]
+      , TestProduction 0 [1] [[2],[10]]
+      , TestProduction 0 [1] [[2],[20]]
+      ]
+  , pmcfgCase "incomplete products remain uncompressed"
+      [ TestProduction 0 [1] [[1],[10]]
+      , TestProduction 0 [1] [[1],[20]]
+      , TestProduction 0 [1] [[2],[10]]
+      ]
+  , pmcfgCase "overlapping rectangles preserve area predicate"
+      [ TestProduction 0 [1] [[1,2],[10]]
+      , TestProduction 0 [1] [[1],[10,20]]
+      ]
+  , pmcfgCase "different arities remain equivalent"
+      [ TestProduction 0 [1] [[1]]
+      , TestProduction 0 [1] [[1],[2]]
+      ]
+  , pmcfgCase "fun ids are first-encounter based"
+      [ TestProduction 0 [5] [[1]]
+      , TestProduction 0 [6] [[2]]
+      , TestProduction 1 [5] [[3]]
+      , TestProduction 1 [6] [[4]]
+      ]
+  , pmcfgCase "nullary production"
+      [ TestProduction 0 [10] []
+      ]
+  , pmcfgCase "lindef-shaped production"
+      [ TestProduction 0 [7,8] [[-4]]
+      ]
+  , pmcfgCase "linref-shaped production"
+      [ TestProduction (-4) [9] [[1,2,3]]
+      ]
+  , pmcfgCorpusCase "generated production corpus" generatedProductionCorpora
+  ]
+
+pmcfgCase :: String -> [TestProduction] -> Test
+pmcfgCase name prods =
+  Test ("pmcfg/" ++ name) (return (compareProductions prods))
+
+pmcfgCorpusCase :: String -> [[TestProduction]] -> Test
+pmcfgCorpusCase name corpora =
+  Test ("pmcfg/" ++ name) $
+    return $
+      case [(i,prods,msg) | (i,prods) <- zip [(1 :: Int)..] corpora, Left msg <- [compareProductions prods]] of
+        [] -> Right ()
+        failures ->
+          Left $
+            unlines $
+              ("checked: " ++ show (length corpora) ++ " corpora")
+              : concatMap describeFailure (take 5 failures)
+  where
+    describeFailure (i,prods,msg) =
+      [ "corpus: " ++ show i
+      , "inputs: " ++ show prods
+      , msg
+      ]
+
+compareProductions :: [TestProduction] -> Either String ()
+compareProductions prods =
+  let results = pmcfgResults prods
+      pre = pmcfgPre results
+      optimized = pmcfgOptimized results
+  in if pre == optimized
+       then Right ()
+       else Left $
+         unlines [ "inputs:    " ++ show prods
+                 , "pre:       " ++ show pre
+                 , "optimized: " ++ show optimized
+                 ]
+
+generatedSchemas :: [TestSchema]
+generatedSchemas =
+  take 160 $
+  filter ((<= 128) . schemaAlternatives) $
+  nub $
+  concat levels
+  where
+    leafs =
+      [ TestStr
+      , TestPar 1 [0]
+      , TestPar 1 [0,1]
+      , TestPar 2 [0,1]
+      , TestPar 3 [1,2]
+      , TestPar 2 [0,0,1]
+      ]
+
+    levels = take 4 (iterate grow leafs)
+
+    grow schemas =
+      leafs ++
+      [ TestRec [a,b] | a <- schemas, b <- leafs, schemaAlternatives a * schemaAlternatives b <= 128 ] ++
+      [ TestTbl [a,b] | a <- schemas, b <- leafs, schemaAlternatives a * schemaAlternatives b <= 128 ] ++
+      [ TestRec [a, TestTbl [b,c]]
+      | a <- take 8 schemas
+      , b <- take 4 leafs
+      , c <- take 4 leafs
+      , schemaAlternatives a * schemaAlternatives b * schemaAlternatives c <= 128
+      ]
+
+schemaAlternatives :: TestSchema -> Int
+schemaAlternatives TestStr = 1
+schemaAlternatives (TestPar _ choices) = length choices
+schemaAlternatives (TestRec schemas) = product (map schemaAlternatives schemas)
+schemaAlternatives (TestTbl schemas) = product (map schemaAlternatives schemas)
+
+generatedProductionCorpora :: [[TestProduction]]
+generatedProductionCorpora =
+  [ take n generatedProductions
+  | n <- [1..40]
+  ] ++
+  [ [generatedProductions !! i | i <- indexes]
+  | indexes <- [ [0,1,2,1]
+               , [3,4,5,6,7]
+               , [8,9,10,11,12,13]
+               , [14,15,16,17,18,19,20]
+               ]
+  ]
+
+generatedProductions :: [TestProduction]
+generatedProductions =
+  [ TestProduction fid seqs args
+  | fid <- [0,1,2,-4]
+  , seqs <- [[1], [1,2], [2,1], [3,4,5]]
+  , args <- [ []
+            , [[1]]
+            , [[1,2]]
+            , [[1],[10]]
+            , [[1],[10,20]]
+            , [[1,2],[10]]
+            , [[1],[10],[20,30]]
+            , [[-4]]
+            ]
+  ]