Tests

1 files changed, 48 insertions, 4 deletions

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