Support dynamic param values

src/compiler/GF/Compile/GrammarToLPGF.hs

@@ -11,7 +11,8 @@ import GF.Compile.GrammarToCanonical (grammar2canonical)
 import GF.Infra.Option
 import GF.Infra.UseIO (IOE)
 
-import Control.Monad (unless)
+import qualified Control.Monad.State as CMS
+import Control.Monad (unless, forM_)
 import Data.Either (lefts, rights)
 import Data.List (elemIndex)
 import qualified Data.Map as Map
@@ -27,20 +28,20 @@ mkCanon2lpgf opts gr am = do
     L.abstract = abs,
     L.concretes = Map.fromList cncs
   }
-  -- print lpgf
+  -- dumpCanonical canon
+  -- dumpLPGF lpgf
   return lpgf
   where
-    C.Grammar ab cncs = grammar2canonical opts am gr
+    canon@(C.Grammar ab cncs) = grammar2canonical opts am gr
 
     mkAbstr :: C.Abstract -> IOE (CId, L.Abstr)
     mkAbstr (C.Abstract modId flags cats funs) = return (mdi2i modId, L.Abstr {})
 
     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
+        paramTuples = mkParamTuples params
         es = map mkLin lindefs
         lins = Map.fromList $ rights es
 
@@ -64,12 +65,29 @@ mkCanon2lpgf opts gr am = do
 
               C.ErrorValue err -> return $ L.LFError err
 
-              C.ParamConstant _ -> do -- TODO only works when param value can be known at compile time
+              -- when param value can be known at compile time
+              -- this case is actually covered below and can be omitted, but it will result in smaller LPGF
+              -- and should thus be seen as an optimisation
+              C.ParamConstant _ | isParamConstant lv -> do
                 let mixs = map (elemIndex lv) paramMap
                 case catMaybes mixs of
                   ix:_ -> return $ L.LFInt (ix+1)
                   _ -> Left $ printf "Cannot find param value: %s" (show lv)
 
+              -- when param value is dynamic
+              C.ParamConstant (C.Param pid pids) -> do
+                -- get param group index and defn for this constructor
+                let defs = [ (gix,d) | (gix,d@(C.ParamDef _ ps)) <- zip [0..] params, any (\(C.Param p _) -> p == pid) ps ] :: [(Int,C.ParamDef)]
+                (gix,def) <- if null defs then Left (printf "Cannot find param group: %s" (show pid)) else Right $ head defs
+                let (C.ParamDef _ defpids) = def
+
+                pidIx <- eitherElemIndex pid [ p | C.Param p _ <- defpids ]
+                pids' <- mapM val2lin pids
+                let
+                  tuple = paramTuples !! gix
+                  term = foldl L.LFProjection tuple (L.LFInt (pidIx+1):pids')
+                return term
+
               -- PredefValue PredefId -- TODO predef not supported
 
               C.RecordValue rrvs -> do
@@ -129,16 +147,21 @@ mkCanon2lpgf opts gr am = do
         L.lins = lins
       })
 
-eitherElemIndex :: (Eq a, Show a) => a -> [a] -> Either String Int
-eitherElemIndex x xs = case elemIndex x xs of
-  Just ix -> Right ix
-  Nothing -> Left $ printf "Cannot find: %s" (show x)
+-- | 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 ""
 
-mdi2i :: C.ModId -> CId
-mdi2i (C.ModId i) = mkCId i
-
-fi2i :: C.FunId -> CId
-fi2i (C.FunId i) = mkCId i
+-- | 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]]
@@ -146,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 _ _) = [] -- TODO ?
 
     mk'' :: C.ParamValueDef -> [C.LinValue]
     mk'' (C.Param pid []) = [C.ParamConstant (C.Param pid [])]
@@ -158,3 +181,45 @@ mkParamMap defs = map mk' defs
           | p <- pids
           , def <- [ d | d@(C.ParamDef pid _) <- defs, pid == p ]
           ] :: [[C.LinValue]]
+
+-- | Build LPGF tuple of param values, needed when param index is looked up dynamically
+mkParamTuples :: [C.ParamDef] -> [L.LinFun]
+mkParamTuples defs = map (\def -> CMS.evalState (mk' def) 1) defs
+  where
+    mk' :: C.ParamDef -> CMS.State Int L.LinFun
+    mk' (C.ParamDef _ pids) = do
+      ms <- mapM mk'' pids
+      return $ L.LFTuple ms
+    mk' (C.ParamAliasDef _ _) = return $ L.LFTuple [] -- 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
+
+-- | Is a param value completely constant/static?
+isParamConstant :: C.LinValue -> Bool
+isParamConstant (C.ParamConstant (C.Param _ lvs)) = all isParamConstant lvs
+isParamConstant _ = False
+
+-- | Convert Maybe to Either value with error
+m2e :: String -> Maybe a -> Either String a
+m2e err = maybe (Left err) Right
+
+-- | Wrap elemIndex into Either value
+eitherElemIndex :: (Eq a, Show a) => a -> [a] -> Either String Int
+eitherElemIndex x xs = m2e (printf "Cannot find: %s" (show x)) (elemIndex x xs)
+
+mdi2i :: C.ModId -> CId
+mdi2i (C.ModId i) = mkCId i
+
+fi2i :: C.FunId -> CId
+fi2i (C.FunId i) = mkCId i

testsuite/lpgf/Params.gf

@@ -1,4 +1,4 @@
-abstract Scratch = {
+abstract Params = {
   cat S ; F ;
   fun
     FtoS : F -> S ;

testsuite/lpgf/Params.treebank

@@ -0,0 +1,5 @@
+Params: FtoS f1
+ParamsCnc: PR R1 Q2
+
+Params: FtoS f2
+ParamsCnc: PR R2 _

testsuite/lpgf/ParamsCnc.gf

@@ -0,0 +1,20 @@
+concrete ParamsCnc of Params = {
+  param
+    R = R1 | R2 ;
+    P = PR R Q | PP ;
+    Q = Q1 | Q2 ;
+  lincat
+    S = Str ;
+    F = { r : R } ;
+  lin
+    f1 = { r = R1 } ;
+    f2 = { r = R2 } ;
+    FtoS f = tbl ! PR f.r Q2 ;
+  oper
+    tbl = table {
+      PR R1 Q1 => "PR R1 Q1" ;
+      PR R1 Q2 => "PR R1 Q2" ;
+      PR R2 _ => "PR R2 _" ;
+      PP => "PP"
+    } ;
+}

testsuite/lpgf/Scratch.treebank

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

testsuite/lpgf/ScratchCnc.gf

@@ -1,18 +0,0 @@
-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,9 +15,9 @@ dir = "testsuite" </> "lpgf"
 
 main :: IO ()
 main = do
-  doGrammar "Scratch"
+  doGrammar "Params"
   doGrammar "Walking"
-  doGrammar "Foods"
+  -- doGrammar "Foods"
 
 doGrammar :: String -> IO ()
 doGrammar gname = do
@@ -55,6 +55,7 @@ doGrammar gname = do
       putStrLn ""
       error "Test failed"
 
+-- | Group list of lines by blank lines
 groups :: [String] -> [[String]]
 groups [] = []
 groups ss = let (a,b) = break (=="") ss in a : groups (drop 1 b)