Support nested parameters, but fails with non-static values (see FoodsBull, ASg kind.g).

src/compiler/GF/Compile/GrammarToLPGF.hs

@@ -37,7 +37,10 @@ mkCanon2lpgf opts gr am = do
 
     mkConcr :: C.Concrete -> IOE (CId, L.Concr)
     mkConcr (C.Concrete modId absModId flags params lincats lindefs) = do
+      -- print params
+      -- print lindefs
       let
+        paramMap = mkParamMap params
         es = map mkLin lindefs
         lins = Map.fromList $ rights es
 
@@ -61,16 +64,11 @@ mkCanon2lpgf opts gr am = do
 
               C.ErrorValue err -> return $ L.LFError err
 
-              C.ParamConstant p@(C.Param (C.ParamId (C.Qual _ _)) _) -> do
+              C.ParamConstant _ -> do -- TODO only works when param value can be known at compile time
-                let
+                let mixs = map (elemIndex lv) paramMap
-                  mixs =
-                    [ elemIndex p pvs
-                    | C.ParamDef pid pvds <- params
-                    , let pvs = map (\(C.Param pid []) -> C.Param pid []) pvds -- TODO assumption of [] probably wrong
-                    ] -- look in all paramdefs
                 case catMaybes mixs of
                   ix:_ -> return $ L.LFInt (ix+1)
-                  _ -> Left $ printf "Cannot find param value: %s" (show p)
+                  _ -> Left $ printf "Cannot find param value: %s" (show lv)
 
               -- PredefValue PredefId -- TODO predef not supported
 
@@ -78,8 +76,8 @@ mkCanon2lpgf opts gr am = do
                 ts <- sequence [ val2lin lv | C.RecordRow lid lv <- rrvs ]
                 return $ L.LFTuple ts
 
-              C.TableValue lt trvs -> do
+              C.TableValue lt trvs -> do -- lt is type
-                ts <- sequence [ val2lin lv | C.TableRow lpatt lv <- trvs ] -- TODO variables in lhs
+                ts <- sequence [ val2lin lv | C.TableRow lpatt lv <- trvs ] -- TODO variables in lhs ?
                 return $ L.LFTuple ts
 
               C.TupleValue lvs -> do
@@ -141,3 +139,22 @@ mdi2i (C.ModId i) = mkCId i
 
 fi2i :: C.FunId -> CId
 fi2i (C.FunId i) = mkCId i
+
+-- | Enumerate all paramvalue combinations for looking up index numbers
+mkParamMap :: [C.ParamDef] -> [[C.LinValue]]
+mkParamMap defs = map mk' defs
+  where
+    mk' :: C.ParamDef -> [C.LinValue]
+    mk' (C.ParamDef _ pids) = concatMap mk'' pids
+    mk' (C.ParamAliasDef _ _) = [] -- TODO
+
+    mk'' :: C.ParamValueDef -> [C.LinValue]
+    mk'' (C.Param pid []) = [C.ParamConstant (C.Param pid [])]
+    mk'' (C.Param pid pids) =
+      [ C.ParamConstant (C.Param pid k) | k <- sequence kids ]
+      where
+        kids =
+          [ mk' def
+          | p <- pids
+          , def <- [ d | d@(C.ParamDef pid _) <- defs, pid == p ]
+          ] :: [[C.LinValue]]

testsuite/lpgf/Foods.treebank

@@ -1,14 +1,19 @@
 Foods: Pred (That Wine) Delicious
+FoodsBul: онова вино е превъзходно
 FoodsEng: that wine is delicious
 
 Foods: Pred (This Pizza) (Very Boring)
+FoodsBul: тази пица е много еднообразна
 FoodsEng: this pizza is very boring
 
 Foods: Pred (This Cheese) Fresh
+FoodsBul: това сирене е свежо
 FoodsEng: this cheese is fresh
 
 Foods: Pred (Those Fish) Warm
+FoodsBul: онези риби са горещи
 FoodsEng: those fish are warm
 
 Foods: Pred (That (Mod Boring (Mod Italian Pizza))) Expensive
+FoodsBul: онази еднообразна италианска пица е скъпа
 FoodsEng: that boring Italian pizza is expensive

testsuite/lpgf/FoodsBul.gf

@@ -0,0 +1,43 @@
+-- (c) 2009 Krasimir Angelov under LGPL
+
+concrete FoodsBul of Foods = {
+  
+  flags
+    coding = utf8;
+
+  param
+    Gender = Masc | Fem | Neutr;
+    Number = Sg | Pl;
+    Agr    = ASg Gender | APl ;
+
+  lincat
+    Comment = Str ;
+    Quality = {s : Agr => Str} ;
+    Item = {s : Str; a : Agr} ;
+    Kind = {s : Number => Str; g : Gender} ;
+
+  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};
+    Cheese = {s = table {Sg => "сирене"; Pl => "сирена"}; g = Neutr};
+    Fish   = {s = table {Sg => "риба";   Pl => "риби"};   g = Fem};
+    Pizza  = {s = table {Sg => "пица";   Pl => "пици"};   g = Fem};
+
+    Very qual = {s = \\g => "много" ++ qual.s ! g};
+
+    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 => "италиански"}}; 
+    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/Scratch.gf

@@ -0,0 +1,7 @@
+abstract Scratch = {
+  cat S ; F ;
+  fun
+    FtoS : F -> S ;
+    f1 : F ;
+    f2 : F ;
+}

testsuite/lpgf/Scratch.treebank

@@ -0,0 +1,2 @@
+Scratch: FtoS f1
+ScratchCnc: R1 Q2

testsuite/lpgf/ScratchCnc.gf

@@ -0,0 +1,18 @@
+concrete ScratchCnc of Scratch = {
+  param
+    R = R1 | R2 ;
+    P = PR R Q | PP ;
+    Q = Q1 | Q2 ;
+  lincat
+    S = Str ;
+    F = { p : P => Str } ;
+  lin
+    f1 = f2 ;
+    f2 = { p = table {
+      PR R1 Q1 => "R1 Q1" ;
+      PR R1 Q2 => "R1 Q2" ;
+      PR R2 _ => "R2 _" ;
+      PP => "PP"
+     } } ;
+    FtoS f = f.p ! PR R1 Q2 ;
+}

testsuite/lpgf/run.hs

@@ -15,6 +15,7 @@ dir = "testsuite" </> "lpgf"
 
 main :: IO ()
 main = do
+  doGrammar "Scratch"
   doGrammar "Walking"
   doGrammar "Foods"