diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs index a4b2840ae..669aec39e 100644 --- a/src/compiler/GF/Compile/GrammarToLPGF.hs +++ b/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 - let - 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 + C.ParamConstant _ -> do -- TODO only works when param value can be known at compile time + let mixs = map (elemIndex lv) paramMap 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 - ts <- sequence [ val2lin lv | C.TableRow lpatt lv <- trvs ] -- TODO variables in lhs + C.TableValue lt trvs -> do -- lt is type + 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]] diff --git a/testsuite/lpgf/Foods.treebank b/testsuite/lpgf/Foods.treebank index 02efbf644..8985961a5 100644 --- a/testsuite/lpgf/Foods.treebank +++ b/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 diff --git a/testsuite/lpgf/FoodsBul.gf b/testsuite/lpgf/FoodsBul.gf new file mode 100644 index 000000000..ac9127669 --- /dev/null +++ b/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 => "еднообразни"}}; + +} diff --git a/testsuite/lpgf/Scratch.gf b/testsuite/lpgf/Scratch.gf new file mode 100644 index 000000000..1f22a4a06 --- /dev/null +++ b/testsuite/lpgf/Scratch.gf @@ -0,0 +1,7 @@ +abstract Scratch = { + cat S ; F ; + fun + FtoS : F -> S ; + f1 : F ; + f2 : F ; +} diff --git a/testsuite/lpgf/Scratch.treebank b/testsuite/lpgf/Scratch.treebank new file mode 100644 index 000000000..d839a5f20 --- /dev/null +++ b/testsuite/lpgf/Scratch.treebank @@ -0,0 +1,2 @@ +Scratch: FtoS f1 +ScratchCnc: R1 Q2 diff --git a/testsuite/lpgf/ScratchCnc.gf b/testsuite/lpgf/ScratchCnc.gf new file mode 100644 index 000000000..4b32bcafb --- /dev/null +++ b/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 ; +} diff --git a/testsuite/lpgf/run.hs b/testsuite/lpgf/run.hs index 70aadcd84..272a0fadb 100644 --- a/testsuite/lpgf/run.hs +++ b/testsuite/lpgf/run.hs @@ -15,6 +15,7 @@ dir = "testsuite" "lpgf" main :: IO () main = do + doGrammar "Scratch" doGrammar "Walking" doGrammar "Foods"