From 8cfaa69b6e2e9c4053b495fe7b4cd49a647ac60a Mon Sep 17 00:00:00 2001 From: "John J. Camilleri" Date: Fri, 12 Feb 2021 23:51:16 +0100 Subject: [PATCH] Handle record tables, pass FoodSwe in testsuite --- src/compiler/GF/Compile/GrammarToLPGF.hs | 65 +++++++++++++++++------- src/runtime/haskell/LPGF.hs | 19 ++++--- testsuite/lpgf/Foods.gf | 2 +- testsuite/lpgf/FoodsSwe.gf | 2 +- testsuite/lpgf/run.hs | 4 +- 5 files changed, 60 insertions(+), 32 deletions(-) diff --git a/src/compiler/GF/Compile/GrammarToLPGF.hs b/src/compiler/GF/Compile/GrammarToLPGF.hs index 52102ec18..ad33ecdc1 100644 --- a/src/compiler/GF/Compile/GrammarToLPGF.hs +++ b/src/compiler/GF/Compile/GrammarToLPGF.hs @@ -10,11 +10,12 @@ import GF.Compile.GrammarToCanonical (grammar2canonical) import GF.Infra.Option import GF.Infra.UseIO (IOE) +import GF.Text.Pretty (pp, render) import qualified Control.Monad.State as CMS import Control.Monad (unless, forM_) import Data.Either (lefts, rights) -import Data.List (elemIndex, find) +import Data.List (elemIndex, find, groupBy) import qualified Data.Map as Map import Data.Maybe (catMaybes) import Text.Printf (printf) @@ -28,6 +29,7 @@ mkCanon2lpgf opts gr am = do L.abstract = abs, L.concretes = Map.fromList cncs } + -- ppCanonical canon -- dumpCanonical canon -- dumpLPGF lpgf return lpgf @@ -94,8 +96,18 @@ mkCanon2lpgf opts gr am = do ts <- sequence [ val2lin lv | C.RecordRow lid lv <- rrvs ] return $ L.LFTuple ts - C.TableValue lt trvs -> do -- lt is type - ts <- sequence [ val2lin lv | C.TableRow lpatt lv <- trvs ] -- TODO variables in lhs ? + C.TableValue lt trvs | isRecordType lt -> go trvs + where + go :: [C.TableRowValue] -> Either String L.LinFun + go [C.TableRow _ lv] = val2lin lv + go trvs = do + let grps = groupBy (\(C.TableRow (C.RecordPattern rps1) _) (C.TableRow (C.RecordPattern rps2) _) -> head rps1 == head rps2) trvs + ts <- mapM (go . map (\(C.TableRow (C.RecordPattern rps) lv) -> C.TableRow (C.RecordPattern (tail rps)) lv)) grps + return $ L.LFTuple ts + + -- C.TableValue lt trvs | isParamType lt -> do + C.TableValue _ trvs -> do + ts <- sequence [ val2lin lv | C.TableRow _ lv <- trvs ] -- TODO variables in lhs ? return $ L.LFTuple ts C.TupleValue lvs -> do @@ -147,21 +159,6 @@ mkCanon2lpgf opts gr am = do L.lins = lins }) --- | Dump canonical grammar, for debugging -dumpCanonical :: C.Grammar -> IO () -dumpCanonical (C.Grammar ab cncs) = do - putStrLn "" - forM_ cncs $ \(C.Concrete modId absModId flags params lincats lindefs) -> do - mapM_ print params - putStrLn "" - mapM_ print lindefs - putStrLn "" - --- | Dump LPGF, for debugging -dumpLPGF :: LPGF -> IO () -dumpLPGF lpgf = - forM_ (Map.toList $ L.concretes lpgf) $ \(cid,concr) -> - mapM_ print (Map.toList $ L.lins concr) -- | Enumerate all paramvalue combinations for looking up index numbers mkParamMap :: [C.ParamDef] -> [[C.LinValue]] @@ -207,11 +204,23 @@ mkParamTuples defs = map (\def -> CMS.evalState (mk' def) 1) defs ] return $ L.LFTuple ns +isParamType :: C.LinType -> Bool +isParamType (C.ParamType _) = True +isParamType _ = False + +isRecordType :: C.LinType -> Bool +isRecordType (C.RecordType _) = True +isRecordType _ = False + -- | Is a param value completely constant/static? isParamConstant :: C.LinValue -> Bool isParamConstant (C.ParamConstant (C.Param _ lvs)) = all isParamConstant lvs isParamConstant _ = False +isLFInt :: L.LinFun -> Bool +isLFInt (L.LFInt _) = True +isLFInt _ = False + -- | Convert Maybe to Either value with error m2e :: String -> Maybe a -> Either String a m2e err = maybe (Left err) Right @@ -225,3 +234,23 @@ mdi2i (C.ModId i) = mkCId i fi2i :: C.FunId -> CId fi2i (C.FunId i) = mkCId i + +-- | Pretty-print canonical grammar, for debugging +ppCanonical :: C.Grammar -> IO () +ppCanonical = putStrLn . render . pp + +-- | Dump canonical grammar, for debugging +dumpCanonical :: C.Grammar -> IO () +dumpCanonical (C.Grammar ab cncs) = do + putStrLn "" + forM_ cncs $ \(C.Concrete modId absModId flags params lincats lindefs) -> do + mapM_ print params + putStrLn "" + mapM_ print lindefs + putStrLn "" + +-- | Dump LPGF, for debugging +dumpLPGF :: LPGF -> IO () +dumpLPGF lpgf = + forM_ (Map.toList $ L.concretes lpgf) $ \(cid,concr) -> + mapM_ print (Map.toList $ L.lins concr) diff --git a/src/runtime/haskell/LPGF.hs b/src/runtime/haskell/LPGF.hs index 57e099fcd..9bbab7f31 100644 --- a/src/runtime/haskell/LPGF.hs +++ b/src/runtime/haskell/LPGF.hs @@ -130,16 +130,11 @@ eval cxt t = case t of LFInt i -> LFInt i LFTuple ts -> LFTuple vs where vs = map (eval cxt) ts - LFProjection t u -> vs !! (i-1) - where - -- LFTuple vs = eval cxt t - -- LFInt i = eval cxt u - vs = case eval cxt t of - LFTuple vs -> vs - x -> error $ "ERROR expected LFTuple, got: " ++ show x - i = case eval cxt u of - LFInt j -> j - x -> error $ "ERROR expected LFInt, got: " ++ show x + LFProjection t u -> + case (eval cxt t, eval cxt u) of + (LFTuple vs, LFInt i) -> vs !! (i-1) + (tp@(LFTuple _), LFTuple is) | all isInt is -> foldl (\(LFTuple vs) (LFInt i) -> vs !! (i-1)) tp is + (t',u') -> error $ printf "Incompatible projection:\n%s\n%s" (show t') (show u') LFArgument i -> cxt !! (i-1) -- | Turn concrete syntax terms into an actual string @@ -156,3 +151,7 @@ lin2string l = case l of | 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 + +isInt :: LinFun -> Bool +isInt (LFInt _) = True +isInt _ = False diff --git a/testsuite/lpgf/Foods.gf b/testsuite/lpgf/Foods.gf index 8ea02f39d..12ef2d9f6 100644 --- a/testsuite/lpgf/Foods.gf +++ b/testsuite/lpgf/Foods.gf @@ -10,6 +10,6 @@ abstract Foods = { Mod : Quality -> Kind -> Kind ; Wine, Cheese, Fish, Pizza : Kind ; Very : Quality -> Quality ; - Fresh, Warm, Italian, + Fresh, Warm, Italian, Expensive, Delicious, Boring : Quality ; } diff --git a/testsuite/lpgf/FoodsSwe.gf b/testsuite/lpgf/FoodsSwe.gf index c3ed38abb..770a272e2 100644 --- a/testsuite/lpgf/FoodsSwe.gf +++ b/testsuite/lpgf/FoodsSwe.gf @@ -1,6 +1,6 @@ -- (c) 2009 Aarne Ranta under LGPL -concrete FoodsSwe of Foods = FoodsI with +concrete FoodsSwe of Foods = FoodsI with (Syntax = SyntaxSwe), (LexFoods = LexFoodsSwe) ** {flags language = sv_SE;} ; diff --git a/testsuite/lpgf/run.hs b/testsuite/lpgf/run.hs index 8cc1cd082..b47bb17e5 100644 --- a/testsuite/lpgf/run.hs +++ b/testsuite/lpgf/run.hs @@ -15,10 +15,10 @@ dir = "testsuite" "lpgf" main :: IO () main = do + doGrammar "Tables" doGrammar "Params" doGrammar "Walking" doGrammar "Foods" - doGrammar "Tables" doGrammar :: String -> IO () doGrammar gname = do @@ -42,7 +42,7 @@ doGrammar gname = do printf "%s: %s\n" gname ast let Just tree = readExpr ast - -- Do some linearization + -- Do some linearization langs = [ printf "%s: %s" (showLanguage lang) (linearizeConcr concr tree) | (lang,concr) <- Map.toList (concretes lpgf)