diff options
Diffstat (limited to 'src/compiler/GF/Compile/GeneratePmcfgPre.hs')
| -rw-r--r-- | src/compiler/GF/Compile/GeneratePmcfgPre.hs | 52 |
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 |