From 34f0fc0ba79cfd84546f8108b536998b29d456a3 Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Wed, 3 Feb 2021 15:41:27 +0100 Subject: [PATCH] Fix bug in dynamic parameter handling, compile FoodsBul successfully --- src/compiler/GF/Compile/GrammarToLPGF.hs | 24 +++++++++++++----------- src/runtime/haskell/LPGF.hs | 9 +++++++++ testsuite/lpgf/FoodsBul.gf | 10 +++++----- testsuite/lpgf/Params.treebank | 2 +- testsuite/lpgf/ParamsCnc.gf | 7 ++++--- testsuite/lpgf/run.hs | 2 +- 6 files changed, 33 insertions(+), 21 deletions(-) diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs index 2272ca076..91009ef0a 100644 --- a/src/compiler/GF/Compile/GrammarToLPGF.hs +++ b/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 - ms <- sequence - [ mk' def - | p <- pids - , def <- [ d | d@(C.ParamDef pid _) <- defs, pid == p ] - ] - return $ L.LFTuple ms + mk'' (C.Param p0 (pid:pids)) = do + let Just def = find (\(C.ParamDef p _) -> pid == p) defs + let ms = CMS.evalState (mk' def) 1 + let L.LFTuple ms' = ms + ns <- sequence + [ mk'' (C.Param p0 pids) + | m <- ms' + ] + return $ L.LFTuple ns -- | Is a param value completely constant/static? isParamConstant :: C.LinValue -> Bool diff --git a/src/runtime/haskell/LPGF.hs b/src/runtime/haskell/LPGF.hs index 83d4f8514..34bb537cd 100644 --- a/src/runtime/haskell/LPGF.hs +++ b/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 diff --git a/testsuite/lpgf/FoodsBul.gf b/testsuite/lpgf/FoodsBul.gf index ac9127669..3e9b556af 100644 --- a/testsuite/lpgf/FoodsBul.gf +++ b/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 => "еднообразни"}}; - + } diff --git a/testsuite/lpgf/Params.treebank b/testsuite/lpgf/Params.treebank index cd752b882..12e3a2c15 100644 --- a/testsuite/lpgf/Params.treebank +++ b/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 _ diff --git a/testsuite/lpgf/ParamsCnc.gf b/testsuite/lpgf/ParamsCnc.gf index 6c935456c..d0b12c1d0 100644 --- a/testsuite/lpgf/ParamsCnc.gf +++ b/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" } ; diff --git a/testsuite/lpgf/run.hs b/testsuite/lpgf/run.hs index b7b0c2285..219e11a76 100644 --- a/testsuite/lpgf/run.hs +++ b/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