Fix bug in dynamic parameter handling, compile FoodsBul successfully

src/compiler/GF/Compile/GrammarToLPGF.hs

@@ -14,7 +14,7 @@ import GF.Infra.UseIO (IOE)
 import qualified Control.Monad.State as CMS
 import Control.Monad (unless, forM_)
 import Data.Either (lefts, rights)
-import Data.List (elemIndex)
+import Data.List (elemIndex, find)
 import qualified Data.Map as Map
 import Data.Maybe (catMaybes)
 import Text.Printf (printf)
@@ -169,7 +169,7 @@ mkParamMap defs = map mk' defs
   where
     mk' :: C.ParamDef -> [C.LinValue]
     mk' (C.ParamDef _ pids) = concatMap mk'' pids
-    mk' (C.ParamAliasDef _ _) = [] -- TODO ?
+    mk' (C.ParamAliasDef _ _) = error "mkParamMap not implemented for ParamAliasDef" -- TODO
 
     mk'' :: C.ParamValueDef -> [C.LinValue]
     mk'' (C.Param pid []) = [C.ParamConstant (C.Param pid [])]
@@ -179,7 +179,7 @@ mkParamMap defs = map mk' defs
         kids =
           [ mk' def
           | p <- pids
-          , def <- [ d | d@(C.ParamDef pid _) <- defs, pid == p ]
+          , let Just def = find (\(C.ParamDef pid _) -> pid == p) defs
           ] :: [[C.LinValue]]
 
 -- | Build LPGF tuple of param values, needed when param index is looked up dynamically
@@ -190,20 +190,22 @@ mkParamTuples defs = map (\def -> CMS.evalState (mk' def) 1) defs
     mk' (C.ParamDef _ pids) = do
       ms <- mapM mk'' pids
       return $ L.LFTuple ms
-    mk' (C.ParamAliasDef _ _) = return $ L.LFTuple [] -- TODO ?
+    mk' (C.ParamAliasDef _ _) = error "mkParamTuples not implemented for ParamAliasDef" -- TODO
 
     mk'' :: C.ParamValueDef -> CMS.State Int L.LinFun
     mk'' (C.Param _ []) = do
       ix <- CMS.get
       CMS.modify (+1)
       return $ L.LFInt ix
-    mk'' (C.Param _ pids) = do
+    mk'' (C.Param p0 (pid:pids)) = do
-      ms <- sequence
+      let Just def = find (\(C.ParamDef p _) -> pid == p) defs
-        [ mk' def
+      let ms = CMS.evalState (mk' def) 1
-        | p <- pids
+      let L.LFTuple ms' = ms
-        , def <- [ d | d@(C.ParamDef pid _) <- defs, pid == p ]
+      ns <- sequence
-        ]
+          [ mk'' (C.Param p0 pids)
-      return $ L.LFTuple ms
+          | m <- ms'
+          ]
+      return $ L.LFTuple ns
 
 -- | Is a param value completely constant/static?
 isParamConstant :: C.LinValue -> Bool

src/runtime/haskell/LPGF.hs

@@ -12,6 +12,9 @@ import Data.Binary (Binary, get, put, encodeFile, decodeFile)
 import qualified Data.Map as Map
 import Text.Printf (printf)
 
+import Prelude hiding ((!!))
+import qualified Prelude
+
 -- | Linearisation-only PGF
 data LPGF = LPGF {
   absname   :: CId,
@@ -147,3 +150,9 @@ lin2string l = case l of
   LFTuple [l] -> lin2string l
   LFConcat l1 l2 -> unwords [lin2string l1, lin2string l2]
   x -> printf "[%s]" (show x)
+
+(!!) :: (Show a) => [a] -> Int -> a
+(!!) xs i
+  | i < 0 = error $ printf "!!: index %d too small for list: %s" i (show xs)
+  | i > length xs - 1 = error $ printf "!!: index %d too large for list: %s" i (show xs)
+  | otherwise = xs Prelude.!! i

testsuite/lpgf/Params.treebank

@@ -1,5 +1,5 @@
 Params: FtoS f1
-ParamsCnc: PR R1 Q2
+ParamsCnc: PR R1 Q1
 
 Params: FtoS f2
 ParamsCnc: PR R2 _

testsuite/lpgf/ParamsCnc.gf

@@ -2,18 +2,19 @@ concrete ParamsCnc of Params = {
   param
     R = R1 | R2 ;
     P = PR R Q | PP ;
-    Q = Q1 | Q2 ;
+    Q = Q3 | Q2 | Q1 ;
   lincat
     S = Str ;
     F = { r : R } ;
   lin
     f1 = { r = R1 } ;
     f2 = { r = R2 } ;
-    FtoS f = tbl ! PR f.r Q2 ;
+    FtoS f = tbl ! PR f.r Q1 ;
   oper
     tbl = table {
-      PR R1 Q1 => "PR R1 Q1" ;
       PR R1 Q2 => "PR R1 Q2" ;
+      PR R1 Q1 => "PR R1 Q1" ;
+      PR R1 Q3 => "PR R1 Q3" ;
       PR R2 _ => "PR R2 _" ;
       PP => "PP"
     } ;

testsuite/lpgf/run.hs

@@ -17,7 +17,7 @@ main :: IO ()
 main = do
   doGrammar "Params"
   doGrammar "Walking"
-  -- doGrammar "Foods"
+  doGrammar "Foods"
 
 doGrammar :: String -> IO ()
 doGrammar gname = do