efficient and nicer implementation for literal categories

3 files changed, 17 insertions, 6 deletions

diff --git a/src/GF/Compile/GFCCtoJS.hs b/src/GF/Compile/GFCCtoJS.hs
index 2c3b762da..c8e4e0e4b 100644
--- a/src/GF/Compile/GFCCtoJS.hs
+++ b/src/GF/Compile/GFCCtoJS.hs
@@ -128,6 +128,7 @@ lins2js p ls = JS.EArray [JS.EArray [sym2js s | s <- Array.elems (sequences p Ar
 
 sym2js :: FSymbol -> JS.Expr
 sym2js (FSymCat n l) = new "ArgProj" [JS.EInt n, JS.EInt l]
+sym2js (FSymLit n l) = new "ArgProj" [JS.EInt n, JS.EInt l]
 sym2js (FSymTok (KS t)) = new "Terminal" [JS.EStr t]
 
 new :: String -> [JS.Expr] -> JS.Expr
diff --git a/src/GF/Compile/GeneratePMCFG.hs b/src/GF/Compile/GeneratePMCFG.hs
index a20496d70..6a5f9ebdf 100644
--- a/src/GF/Compile/GeneratePMCFG.hs
+++ b/src/GF/Compile/GeneratePMCFG.hs
@@ -162,7 +162,10 @@ convertArg (C max) nr path lbl_path lin lins = do
 convertArg (S _) nr path lbl_path lin lins = do
   (_, args) <- readState
   let PFCat _ cat rcs tcs = args !! nr
-  return ((lbl_path, FSymCat nr (index path rcs 0) : lin) : lins)
+      l = index path rcs 0
+      sym | isLiteralCat cat = FSymLit nr l
+          | otherwise        = FSymCat nr l
+  return ((lbl_path, sym : lin) : lins)
   where
     index lbl' (lbl:lbls) idx
       | lbl' == lbl = idx
@@ -257,7 +260,7 @@ expandHOAS abs_defs cnc_defs lincats env =
     add_hoFun env (n,cat) =
       let linRec = reverse $
                    [(l ,[FSymCat 0 i]) | (l,i) <- case arg of {PFCat _ _ rcs _ -> zip rcs [0..]}] ++
-                   [([],[FSymCat i 0]) | i <- [1..n]]
+                   [([],[FSymLit i 0]) | i <- [1..n]]
           (env1,lins) = List.mapAccumL addFSeq env linRec
           newLinRec = mkArray lins
 	  
@@ -274,7 +277,7 @@ expandHOAS abs_defs cnc_defs lincats env =
 
     -- add one PMCFG function for each high-order category: _V : Var -> Cat
     add_varFun env cat =
-      let (env1,seqid) = addFSeq env ([],[FSymCat 0 0])
+      let (env1,seqid) = addFSeq env ([],[FSymLit 0 0])
           lins         = replicate (case res of {PFCat _ _ rcs _ -> length rcs}) seqid
           (env2,funid) = addFFun env1 (FFun _V [[0]] (mkArray lins))
           env3         = foldl (\env res -> addProduction env2 res (FApply funid [fcatVar]))
diff --git a/src/GF/Speech/PGFToCFG.hs b/src/GF/Speech/PGFToCFG.hs
index 37bc9c0e5..ef7f1f868 100644
--- a/src/GF/Speech/PGFToCFG.hs
+++ b/src/GF/Speech/PGFToCFG.hs
@@ -85,17 +85,24 @@ pgfToCFG pgf lang = mkCFG (prCId (lookStartCat pgf)) extCats (startRules ++ conc
         mkRhs = map fsymbolToSymbol . Array.elems
 
         containsLiterals :: Array FPointPos FSymbol -> Bool
-        containsLiterals row = any isLiteralFCat [args!!n | FSymCat n _ <- Array.elems row]
+        containsLiterals row = any isLiteralFCat [args!!n | FSymCat n _ <- Array.elems row] ||
+                               not (null [n | FSymLit n _ <- Array.elems row])   -- only this is needed for PMCFG.
+                                                                                 -- The first line is for backward compat.
 
         fsymbolToSymbol :: FSymbol -> CFSymbol
         fsymbolToSymbol (FSymCat n l)    = NonTerminal (fcatToCat (args!!n) l)
+        fsymbolToSymbol (FSymLit n l)    = NonTerminal (fcatToCat (args!!n) l)
         fsymbolToSymbol (FSymTok (KS t)) = Terminal t
 
         fixProfile :: Array FPointPos FSymbol -> Profile -> Profile
         fixProfile row = concatMap positions
             where
-              nts = zip [0..] [nt | nt@(FSymCat _ _) <- Array.elems row]
-              positions i = [k | (k,FSymCat j _) <- nts, j == i]
+              nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt]
+              positions i = [k | (k,j) <- nts, j == i]
+              
+              getPos (FSymCat j _) = [j]
+              getPos (FSymLit j _) = [j]
+              getPos _             = []
 
         profilesToTerm :: [Profile] -> CFTerm
         profilesToTerm ps = CFObj f (zipWith profileToTerm argTypes ps)