1 files changed, 55 insertions, 7 deletions
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