{-# 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 in if pre == optimized then Right () else Left $ unlines [ "schema: " ++ show schema , "pre: " ++ show pre , "optimized: " ++ show optimized ] 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 argument products 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 argument products 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]] ] ]