summaryrefslogtreecommitdiff
path: root/testsuite
diff options
context:
space:
mode:
Diffstat (limited to 'testsuite')
-rw-r--r--testsuite/pmcfg/fixtures/PmcfgDiff.gf11
-rw-r--r--testsuite/pmcfg/fixtures/PmcfgDiffCnc.gf40
-rw-r--r--testsuite/pmcfg/run.hs268
3 files changed, 319 insertions, 0 deletions
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]]
+ ]
+ ]
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 05:08:39 +0000