More work on params: pass all tests except params1 (!)

src/compiler/GF/Compile/GrammarToLPGF.hs

@@ -1,6 +1,6 @@
 module GF.Compile.GrammarToLPGF (mkCanon2lpgf) where
 
-import LPGF (LPGF (..))
+import LPGF (LPGF (..), LinFun (..))
 import qualified LPGF as L
 
 import PGF.CId
@@ -46,14 +46,13 @@ mkCanon2lpgf opts gr am = do
     mkAbstract :: C.Abstract -> IOE (CId, L.Abstract)
     mkAbstract (C.Abstract modId flags cats funs) = return (mdi2i modId, L.Abstract {})
 
-    mkConcrete :: C.Concrete -> IOE (CId, L.Concrete)
+    mkConcrete :: C.Concrete -> IOE (CId, L.Concrete) -- TODO don't need IO
     mkConcrete (C.Concrete modId absModId flags params lincats lindefs) = do
       let
         (C.Abstract _ _ _ funs) = ab
-        paramMap = mkParamMap params
         paramTuples = mkParamTuples params
-      -- mapM_ (\(C.ParamDef pid _,ptup) -> putStrLn $ show pid ++ "\n" ++ T.unpack (L.render $ L.pp ptup)) (zip params paramTuples)
+      -- mapM_ (\(C.ParamDef (C.ParamId (C.Qual _ pid)) _,ptup) -> putStrLn $ "# " ++ pid ++ "\n" ++ T.unpack (L.render $ L.pp ptup)) (zip params 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' =
@@ -101,16 +100,8 @@ mkCanon2lpgf opts gr am = do
 
               C.ErrorValue err -> return (L.LFError err, Nothing)
 
-              -- when param value is known at compile time
+              -- the expressions built here can be quite large,
-              -- this case is actually covered below and can be omitted,
+              -- but will be reduced during optimisation if possible
-              -- 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)
-                let (C.ParamDef tpid _) = params !! gix
-                return (L.LFInt (ix+1), Just $ C.ParamType (C.ParamTypeId tpid))
-
-              -- when param value is dynamic
               C.ParamConstant (C.Param pid lvs) -> do
                 let
                   collectProjections :: C.LinValue -> Either String [L.LinFun]
@@ -231,62 +222,58 @@ inlineParamAliases defs = if null aliases then defs else map rp' pdefs
       Just (C.ParamAliasDef _ (C.ParamType (C.ParamTypeId p))) -> p
       _ -> pid
 
--- | Enumerate all param value combinations for looking up index numbers.
+-- | Build nested tuple of param values
--- Used when param value is static (known at compile time)
-mkParamMap :: [C.ParamDef] -> [[C.LinValue]]
-mkParamMap defs = map mk' pdefs
-  where
-    pdefs = inlineParamAliases defs
-
-    mk' :: C.ParamDef -> [C.LinValue]
-    mk' (C.ParamDef _ pids) = concatMap mk'' pids
-    mk' (C.ParamAliasDef _ _) = error "mkParamMap not implemented for ParamAliasDef"
-
-    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
-          , let Just def = L.find (\(C.ParamDef pid _) -> pid == p) pdefs
-          ] :: [[C.LinValue]]
-
--- | 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
+mkParamTuples defs = map (addIndexes . mk') pdefs
   where
     pdefs = inlineParamAliases defs
-    paramMap = zip defs (mkParamMap defs)
 
-    mk' :: C.ParamDef -> CMS.State Int L.LinFun
+    mk' :: C.ParamDef -> L.LinFun
-    mk' (C.ParamDef _ pids) = do
+    mk' (C.ParamDef _ pids) = L.LFTuple $ map mk'' pids
-      ms <- mapM mk'' pids
-      return $ L.LFTuple ms
     mk' (C.ParamAliasDef _ _) = error "mkParamTuples not implemented for ParamAliasDef"
 
-    mk'' :: C.ParamValueDef -> CMS.State Int L.LinFun
+    mk'' :: C.ParamValueDef -> L.LinFun
-    mk'' (C.Param _ []) = do
+    mk'' (C.Param _ []) = LFEmpty -- placeholder for terminal node, replaced later
-      ix <- CMS.get
-      CMS.modify (+1)
-      return $ L.LFInt ix
 
-    mk'' x@(C.Param p0 [pid]) = do
+    mk'' x@(C.Param p0 [pid]) =
       let Just def = L.find (\(C.ParamDef p _) -> pid == p) pdefs
-      mk' def
+      in  mk' def
 
-    -- mk'' x@(C.Param p0 [pid1,pid2]) = do
+    mk'' x@(C.Param p0 [pid1,pid2]) =
-    --   let Just (C.ParamDef d1 _) = L.find (\(C.ParamDef p _) -> pid1 == p) pdefs
+      let
-    --   let Just def2 = L.find (\(C.ParamDef p _) -> pid2 == p) pdefs
+        Just def1 = L.find (\(C.ParamDef p _) -> pid1 == p) pdefs
-    --   let x = head [ xs | (C.ParamDef d _,xs) <- map2, d == d1 ]
+        Just def2 = L.find (\(C.ParamDef p _) -> pid2 == p) pdefs
-    --   L.LFTuple <$> sequence [ mk' def2 | _ <- x ]
+        lf1 = mk' def1
+        lf2 = mk' def2
+      in replaceEmpty lf2 lf1
+
+    mk'' x@(C.Param p0 (pid:pids)) =
+      let
+        Just def = L.find (\(C.ParamDef p _) -> pid == p) pdefs
+        this = mk' def
+        rest = mk'' (C.Param p0 pids)
+      in replaceEmpty rest this
+
+    -- traverse LinFun term and replace Empty with sequential index
+    addIndexes :: L.LinFun -> L.LinFun
+    addIndexes lf = CMS.evalState (num lf) 1
+      where
+        num :: L.LinFun -> CMS.State Int L.LinFun
+        num lf = case lf of
+          L.LFEmpty -> do
+            ix <- CMS.get
+            CMS.modify (+1)
+            return $ L.LFInt ix
+          L.LFTuple lfs -> L.LFTuple <$> mapM num lfs
+          x -> error $ "mkParamTuples.number not implemented for: " ++ show x
+
+    -- traverse LinFun term and replace Empty with given term
+    replaceEmpty :: L.LinFun -> L.LinFun -> L.LinFun
+    replaceEmpty with tree = case tree of
+      L.LFEmpty -> with
+      L.LFTuple lfs -> L.LFTuple $ map (replaceEmpty with) lfs
+      x -> error $ "mkParamTuples.replaceEmpty not implemented for: " ++ show x
 
-    mk'' (C.Param p0 (pid:pids)) = do
-      let Just (C.ParamDef dpid _) = L.find (\(C.ParamDef p _) -> pid == p) pdefs
-      let Just (_, lvs) = L.find (\(C.ParamDef d _, lvs) -> dpid == d) paramMap
-      L.LFTuple <$> sequence [ mk'' (C.Param p0 pids) | _ <- lvs ]
 
 -- | Always put 's' reocord field first, then sort alphabetically
 -- This seems to be done inconsistently in the canonical format

testsuite/lpgf/test.hs

@@ -22,12 +22,17 @@ main = do
   case args of
     [] -> do
       doGrammar "unittests" "Bind"
-      doGrammar "unittests" "Tables"
+      doGrammar "unittests" "Missing"
-      doGrammar "unittests" "Params"
+      doGrammar "unittests" "Params1"
+      doGrammar "unittests" "Params2"
+      doGrammar "unittests" "Params3"
       doGrammar "unittests" "Pre"
       doGrammar "unittests" "Projection"
+      doGrammar "unittests" "Tables"
+
       doGrammar "walking" "Walking"
       doGrammar "foods" "Foods"
+      -- doGrammar "phrasebook" "Phrasebook"
     [absname] ->
       doGrammar (takeDirectory absname) (takeBaseName absname)
     absname:langs ->

testsuite/lpgf/unittests/Params.treebank

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

testsuite/lpgf/unittests/Params1.gf

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

testsuite/lpgf/unittests/Params1.treebank

@@ -0,0 +1,5 @@
+Params1: FtoS f1
+Params1Cnc: PRQ _ Q3
+
+Params1: FtoS f2
+Params1Cnc: PRQ (RT _) Q1

testsuite/lpgf/unittests/Params1Cnc.gf

@@ -1,4 +1,4 @@
-concrete ParamsCnc of Params = {
+concrete Params1Cnc of Params1 = {
   param
     P = Px | PRQ R Q | Py ;
     R = R0 | RT T ;

testsuite/lpgf/unittests/Params2.gf

@@ -1,4 +1,5 @@
 abstract Params2 = {
+  flags startcat = MassKind ;
   cat Quality ; MassKind ;
   fun
     Good : Quality;

testsuite/lpgf/unittests/Params3.gf

@@ -0,0 +1,14 @@
+abstract Params3 = {
+  cat G ; S ;
+  fun
+    mkPred : S ;
+    mkModSgHumanTrue : G -> S ;
+    mkModSgHumanFalse : G -> S ;
+    mkModSgNonTrue : S ;
+    mkModSgNonFalse : S ;
+    mkModPl : S ;
+
+    GMasc : G ;
+    GFem : G ;
+    GNeutr : G ;
+}

testsuite/lpgf/unittests/Params3.treebank

@@ -0,0 +1,29 @@
+Params3: mkModPl
+Params3Cnc: mod pl
+
+Params3: mkModSgHumanFalse GFem
+Params3Cnc: mod sg human fem f
+
+Params3: mkModSgHumanFalse GMasc
+Params3Cnc: mod sg human masc f
+
+Params3: mkModSgHumanFalse GNeutr
+Params3Cnc: mod sg human neutr f
+
+Params3: mkModSgHumanTrue GFem
+Params3Cnc: mod sg human fem t
+
+Params3: mkModSgHumanTrue GMasc
+Params3Cnc: mod sg human masc t
+
+Params3: mkModSgHumanTrue GNeutr
+Params3Cnc: mod sg human neutr t
+
+Params3: mkModSgNonFalse
+Params3Cnc: mod sg nonhuman f
+
+Params3: mkModSgNonTrue
+Params3Cnc: mod sg nonhuman f
+
+Params3: mkPred
+Params3Cnc: pred

testsuite/lpgf/unittests/Params3Cnc.gf

@@ -0,0 +1,38 @@
+concrete Params3Cnc of Params3 = {
+
+  param
+    Boolean = True | False;
+    AForm = APred | AMod GenNum;
+    GenNum = GSg Animacy Boolean | GPl;
+    Animacy = Human Gender | Nonhuman ;
+    Gender = Masc | Fem | Neutr;
+  lincat
+    S = Str ;
+    G = { gen : Gender } ;
+    T = AForm => Str ;
+  lin
+    mkPred = tbl ! APred ;
+    mkModSgHumanTrue g = tbl ! AMod (GSg (Human g.gen) True) ;
+    mkModSgHumanFalse g = tbl ! AMod (GSg (Human g.gen) False) ;
+    mkModSgNonTrue = tbl ! AMod (GSg Nonhuman False) ;
+    mkModSgNonFalse = tbl ! AMod (GSg Nonhuman False) ;
+    mkModPl = tbl ! AMod GPl ;
+
+    GMasc = { gen = Masc } ;
+    GFem = { gen = Fem } ;
+    GNeutr = { gen = Neutr } ;
+
+  oper
+    tbl = table {
+      APred => "pred";
+      AMod (GSg (Human Masc) True) => "mod sg human masc t";
+      AMod (GSg (Human Masc) False) => "mod sg human masc f";
+      AMod (GSg (Human Fem) True) => "mod sg human fem t";
+      AMod (GSg (Human Fem) False) => "mod sg human fem f";
+      AMod (GSg (Human Neutr) True) => "mod sg human neutr t";
+      AMod (GSg (Human Neutr) False) => "mod sg human neutr f";
+      AMod (GSg Nonhuman True) => "mod sg nonhuman t";
+      AMod (GSg Nonhuman False) => "mod sg nonhuman f";
+      AMod GPl => "mod pl"
+    } ;
+}