WIP params

src/compiler/GF/Compile/GrammarToLPGF.hs

@@ -52,7 +52,8 @@ mkCanon2lpgf opts gr am = do
         (C.Abstract _ _ _ funs) = ab
         paramMap = mkParamMap params
         paramTuples = mkParamTuples params
-
+      -- mapM_ (putStrLn . T.unpack . L.render . L.pp) paramTuples
+      let
         -- filter out record fields from defn which don't appear in lincat
         -- this seems to be an inconsistency in the canonical representation
         lindefs' =
@@ -100,9 +101,9 @@ mkCanon2lpgf opts gr am = do
 
               C.ErrorValue err -> return (L.LFError err, Nothing)
 
-              -- when param value can be known at compile time
+              -- when param value is known at compile time
-              -- this case is actually covered below and can be omitted, but it will result in smaller LPGF
+              -- this case is actually covered below and can be omitted,
-              -- and should thus be seen as an optimisation
+              -- but will result in smaller LPGF and is thus an optimisation
               C.ParamConstant _ | isParamConstant lv -> do
                 (gix,ix) <- [ (gix,ix) | (gix,lvs) <- zip [0..] paramMap, Just ix <- [elemIndex lv lvs] ]
                             `headOrLeft` printf "Cannot find param value: %s" (show lv)
@@ -110,20 +111,46 @@ mkCanon2lpgf opts gr am = do
                 return (L.LFInt (ix+1), Just $ C.ParamType (C.ParamTypeId tpid))
 
               -- when param value is dynamic
-              C.ParamConstant (C.Param pid pids) -> do
+              C.ParamConstant (C.Param pid lvs) -> do
                 -- get param group index and defn for this constructor
                 (gix,def) <- [ (gix,d) | (gix,d@(C.ParamDef _ ps)) <- zip [0..] params, any (\(C.Param p _) -> p == pid) ps ]
                               `headOrLeft` printf "Cannot find param group: %s" (show pid)
                 let (C.ParamDef tpid defpids) = def
-
                 pidIx <- eitherElemIndex pid [ p | C.Param p _ <- defpids ]
-                pids' <- mapM val2lin pids
+
                 let
-                  tuple = paramTuples !! gix
+                  collectProjections :: C.LinValue -> Either String [L.LinFun]
-                  term = foldl L.LFProjection tuple (L.LFInt (pidIx+1):map fst pids')
+                  collectProjections (C.ParamConstant (C.Param pid lvs)) = do
+                    def <- [ d | d@(C.ParamDef _ ps) <- params, any (\(C.Param p _) -> p == pid) ps ]
+                            `headOrLeft` printf "Cannot find param group: %s" (show pid)
+                    let (C.ParamDef tpid defpids) = def
+                    pidIx <- eitherElemIndex pid [ p | C.Param p _ <- defpids ]
+                    rest <- mapM collectProjections lvs
+                    return $ L.LFInt (pidIx+1) : concat rest
+                  collectProjections lv = do
+                    (lf ,_) <- val2lin lv
+                    return [lf]
+
+                let tuple = paramTuples !! gix
+                lfs <- collectProjections lv
+                let term = foldl L.LFProjection tuple lfs
+
+                -- term <- case lvs of
+                --   [] -> return $ L.LFProjection tuple (L.LFInt (pidIx+1))
+                --   [lv0] -> do
+                --     (lf0,lt0) <- val2lin lv0
+                --     return $ L.LFProjection (L.LFProjection tuple (L.LFInt (pidIx+1))) lf0
+                --   [lv1,lv2] -> do
+                --     (lf1,lt1) <- val2lin lv1
+                --     (lf2,lt2) <- val2lin lv2
+                --     return $ L.LFProjection (L.LFProjection (L.LFProjection tuple (L.LFInt (pidIx+1))) lf1) lf2
+
+                -- lvs' <- mapM val2lin lvs
+                -- let term = foldl L.LFProjection tuple (L.LFInt (pidIx+1):map fst lvs')
+
+                -- term = L.LFProjection (L.LFProjection (L.LFProjection (L.LFProjection tuple (L.LFInt 2 {- AMod -})) (L.LFInt 1 {- GSg -})) (L.LFInt 3 {- Neutr -})) (L.LFInt 1 {- True -})
                 return (term, Just $ C.ParamType (C.ParamTypeId tpid))
 
-              -- https://www.aclweb.org/anthology/W15-3305.pdf
               C.PredefValue (C.PredefId pid) -> case pid of
                 "BIND" -> return (L.LFBind, Nothing)
                 "SOFT_BIND" -> return (L.LFBind, Nothing)
@@ -219,7 +246,8 @@ inlineParamAliases defs = if null aliases then defs else map rp' pdefs
       Just (C.ParamAliasDef _ (C.ParamType (C.ParamTypeId p))) -> p
       _ -> pid
 
--- | Enumerate all paramvalue combinations for looking up index numbers
+-- | Enumerate all param value combinations for looking up index numbers.
+-- Used when param value is static (known at compile time)
 mkParamMap :: [C.ParamDef] -> [[C.LinValue]]
 mkParamMap defs = map mk' pdefs
   where
@@ -240,7 +268,8 @@ mkParamMap defs = map mk' pdefs
           , let Just def = L.find (\(C.ParamDef pid _) -> pid == p) pdefs
           ] :: [[C.LinValue]]
 
--- | Build LPGF tuple of param values, needed when param index is looked up dynamically
+-- | Build nested tuple of param values.
+-- Needed when param value is dynamic (known only at run time)
 mkParamTuples :: [C.ParamDef] -> [L.LinFun]
 mkParamTuples defs = map (\def -> CMS.evalState (mk' def) 1) pdefs
   where
@@ -257,15 +286,24 @@ mkParamTuples defs = map (\def -> CMS.evalState (mk' def) 1) pdefs
       ix <- CMS.get
       CMS.modify (+1)
       return $ L.LFInt ix
+
+    mk'' x@(C.Param p0 [pid]) = do
+      let Just def = L.find (\(C.ParamDef p _) -> pid == p) pdefs
+      mk' def
+
+    -- mk'' x@(C.Param p0 [pid1,pid2]) = do
+    --   let Just def1 = L.find (\(C.ParamDef p _) -> pid1 == p) pdefs
+    --   let Just def2 = L.find (\(C.ParamDef p _) -> pid2 == p) pdefs
+    --   let m1 = CMS.evalState (mk' def1) 1 -- get shape without affecting our counter
+    --   -- m2 <- mk' def2
+    --   let LFTuple m1' = m1
+    --   -- let LFTuple m2' = m2
+    --   L.LFTuple <$> sequence [ mk' def2 | _ <- m1' ]
+
     mk'' (C.Param p0 (pid:pids)) = do
       let Just def = L.find (\(C.ParamDef p _) -> pid == p) pdefs
-      let ms = CMS.evalState (mk' def) 1
+      let L.LFTuple ms = CMS.evalState (mk' def) 1 -- get shape without affecting our counter
-      let L.LFTuple ms' = ms
+      L.LFTuple <$> sequence [ mk'' (C.Param p0 pids) | _ <- ms ]
-      ns <- sequence
-          [ mk'' (C.Param p0 pids)
-          | m <- ms'
-          ]
-      return $ L.LFTuple ns
 
 -- | Always put 's' reocord field first, then sort alphabetically
 -- This seems to be done inconsistently in the canonical format

src/runtime/haskell/LPGF.hs

@@ -272,9 +272,14 @@ instance PP LinFun where
           CMW.tell [ T.replicate (n+1) "  " `T.append` T.pack (show p) | p <- ps ]
           pp' (n+1) d
 
-        c@(LFConcat l1 l2) | isDeep l1 || isDeep l2 -> do
+        c@(LFConcat l1 l2) -> do
-          p "LFConcat"
+          let ts = unConcat c
-          mapM_ (pp' (n+1)) (unConcat c)
+          if any isDeep ts
+          then do
+            p "LFConcat"
+            mapM_ (pp' (n+1)) ts
+          else
+            ps $ "LFConcat " ++ show ts
         LFTuple ls | any isDeep ls -> do
           p "LFTuple"
           mapM_ (pp' (n+1)) ls

testsuite/lpgf/unittests/Params.treebank

@@ -1,5 +1,5 @@
 Params: FtoS f1
-ParamsCnc: PR R1 Q1
+ParamsCnc: PRQ _ Q3
 
 Params: FtoS f2
-ParamsCnc: PR R2 _
+ParamsCnc: PRQ (RT _) Q1

testsuite/lpgf/unittests/Params2.treebank

@@ -1,2 +1,2 @@
 Params2: SuchMassKind Good
-Params2Cnc: gutes
+Params2Cnc: mod sg neutr t

testsuite/lpgf/unittests/Params2Cnc.gf

@@ -1,8 +1,9 @@
 concrete Params2Cnc of Params2 = {
 
   param
+    Boolean = True | False;
     AForm = APred | AMod GenNum;
-    GenNum = GSg Gender | GPl;
+    GenNum = GSg Gender Boolean | GPl;
     Gender = Masc | Fem | Neutr;
 
   lincat
@@ -11,16 +12,19 @@ concrete Params2Cnc of Params2 = {
 
   lin
     SuchMassKind qual = {
-      s = qual.s ! AMod (GSg qual.g)
+      s = qual.s ! AMod (GSg qual.g True)
     };
 
     Good = {
       s =
-        table {APred => "gut";
+        table {APred => "pred";
-               AMod (GSg Masc) => "guter";
+               AMod (GSg Masc True) => "mod sg masc t";
-               AMod (GSg Fem) => "gute";
+               AMod (GSg Fem True) => "mod sg fem t";
-               AMod (GSg Neutr) => "gutes";
+               AMod (GSg Neutr True) => "mod sg neutr t";
-               AMod GPl => "gute"} ;
+               AMod (GSg Masc False) => "mod sg masc f";
+               AMod (GSg Fem False) => "mod sg fem f";
+               AMod (GSg Neutr False) => "mod sg neutr f";
+               AMod GPl => "mod pl"} ;
       g = Neutr
     };
 }

testsuite/lpgf/unittests/ParamsCnc.gf

@@ -1,21 +1,30 @@
 concrete ParamsCnc of Params = {
   param
-    R = R1 | R2 ;
+    P = Px | PRQ R Q | Py ;
-    P = PR R Q | PP ;
+    R = R0 | RT T ;
+    T = T0 | T1 ;
     Q = Q3 | Q2 | Q1 ;
   lincat
     S = Str ;
-    F = { r : R } ;
+    F = { r : R; q : Q } ;
   lin
-    f1 = { r = R1 } ;
+    f1 = { r = R0 ; q = Q3 } ;
-    f2 = { r = R2 } ;
+    f2 = { r = RT T1 ; q = Q1 } ;
-    FtoS f = tbl ! PR f.r Q1 ;
+    FtoS f = tbl ! PRQ f.r f.q ;
   oper
     tbl = table {
-      PR R1 Q2 => "PR R1 Q2" ;
+      Px => "Px" ;
-      PR R1 Q1 => "PR R1 Q1" ;
+      Py => "Py" ;
-      PR R1 Q3 => "PR R1 Q3" ;
+      PRQ R0 Q1 => "PRQ R0 Q1" ;
-      PR R2 _ => "PR R2 _" ;
+      PRQ R0 Q2 => "PRQ R0 Q2" ;
-      PP => "PP"
+      -- PRQ R0 Q3 => "PRQ R0 Q3" ;
+      PRQ (RT _) Q1 => "PRQ (RT _) Q1" ;
+      -- PRQ (RT T0) Q1 => "PRQ (RT T0) Q1" ;
+      PRQ (RT T0) Q2 => "PRQ (RT T0) Q2" ;
+      -- PRQ (RT T0) Q3 => "PRQ (RT T0) Q3" ;
+      -- PRQ (RT T1) Q1 => "PRQ (RT T1) Q1" ;
+      PRQ (RT T1) Q2 => "PRQ (RT T1) Q2" ;
+      -- PRQ (RT T1) Q3 => "PRQ (RT T1) Q3" ;
+      PRQ _ Q3 => "PRQ _ Q3"
     } ;
 }