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/FoodsBul.gf

@@ -1,7 +1,7 @@
 -- (c) 2009 Krasimir Angelov under LGPL
 
 concrete FoodsBul of Foods = {
-  
+
   flags
     coding = utf8;
 
@@ -18,12 +18,12 @@ concrete FoodsBul of Foods = {
 
   lin
     Pred item qual = item.s ++ case item.a of {ASg _ => "е"; APl => "са"} ++ qual.s ! item.a ;
-    
+
     This  kind = {s=case kind.g of {Masc=>"този"; Fem=>"тази";  Neutr=>"това" } ++ kind.s ! Sg; a=ASg kind.g} ;
     That  kind = {s=case kind.g of {Masc=>"онзи"; Fem=>"онази"; Neutr=>"онова"} ++ kind.s ! Sg; a=ASg kind.g} ;
     These kind = {s="тези"  ++ kind.s ! Pl; a=APl} ;
     Those kind = {s="онези" ++ kind.s ! Pl; a=APl} ;
-    
+
     Mod qual kind = {s=\\n => qual.s ! (case n of {Sg => ASg kind.g; Pl => APl}) ++ kind.s ! n; g=kind.g} ;
 
     Wine   = {s = table {Sg => "вино";   Pl => "вина"};   g = Neutr};
@@ -35,9 +35,9 @@ concrete FoodsBul of Foods = {
 
     Fresh     = {s = table {ASg Masc => "свеж";        ASg Fem => "свежа";       ASg Neutr => "свежо";       APl => "свежи"}};
     Warm      = {s = table {ASg Masc => "горещ";       ASg Fem => "гореща";      ASg Neutr => "горещо";      APl => "горещи"}};
-    Italian   = {s = table {ASg Masc => "италиански";  ASg Fem => "италианска";  ASg Neutr => "италианско";  APl => "италиански"}}; 
+    Italian   = {s = table {ASg Masc => "италиански";  ASg Fem => "италианска";  ASg Neutr => "италианско";  APl => "италиански"}};
     Expensive = {s = table {ASg Masc => "скъп";        ASg Fem => "скъпа";       ASg Neutr => "скъпо";       APl => "скъпи"}};
     Delicious = {s = table {ASg Masc => "превъзходен"; ASg Fem => "превъзходна"; ASg Neutr => "превъзходно"; APl => "превъзходни"}};
     Boring    = {s = table {ASg Masc => "еднообразен"; ASg Fem => "еднообразна"; ASg Neutr => "еднообразно"; APl => "еднообразни"}};
-    
+
 }

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