now for every category we store, in PGF, the list of functions for it in source-code order. The order matters for the termination of the exhaustive generation with dependent types.

4 files changed, 13 insertions, 11 deletions

diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index cb447f536..3c4e0445b 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -25,6 +25,7 @@ import GF.Infra.Option
 import GF.Data.Operations
 
 import Data.List
+import Data.Function
 import Data.Char (isDigit,isSpace)
 import qualified Data.Map as Map
 import qualified Data.ByteString.Char8 as BS
@@ -56,7 +57,7 @@ canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do
  where
   -- abstract
   an  = (i2i a)
-  abs = D.Abstr aflags funs cats Map.empty
+  abs = D.Abstr aflags funs cats
   gflags = Map.empty
   aflags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags abm)]
 
@@ -70,11 +71,12 @@ canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do
   lfuns = [(f', (mkType [] ty, mkArrity ma, mkDef pty)) | 
              (f,AbsFun (Just (L _ ty)) ma pty) <- tree2list (M.jments abm), let f' = i2i f]
   funs = Map.fromAscList lfuns
-  lcats = [(i2i c, snd (mkContext [] cont)) |
+  lcats = [(i2i c, (snd (mkContext [] cont),catfuns c)) |
                 (c,AbsCat (Just (L _ cont))) <- tree2list (M.jments abm)]
   cats = Map.fromAscList lcats
-  catfuns = Map.fromList 
-    [(cat,[f | (f, (C.DTyp _ c _,_,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
+  catfuns cat =
+    (map snd . sortBy (compare `on` fst))
+        [(loc,i2i f) | (f,AbsFun (Just (L loc ty)) _ _) <- tree2list (M.jments abm), snd (GM.valCat ty) == cat]
 
   mkConcr lang0 lang mo = do
     lins' <- case mapM (checkLin (funs,lins,lincats) lang) (Map.toList lins) of
diff --git a/src/compiler/GF/Compile/PGFtoLProlog.hs b/src/compiler/GF/Compile/PGFtoLProlog.hs
index 3f2849d63..41d258b3b 100644
--- a/src/compiler/GF/Compile/PGFtoLProlog.hs
+++ b/src/compiler/GF/Compile/PGFtoLProlog.hs
@@ -12,7 +12,7 @@ import Debug.Trace
 grammar2lambdaprolog_mod pgf = render $
   text "module" <+> ppCId (absname pgf) <> char '.' $$
   space $$
-  vcat [ppClauses cat fns | (cat,fs) <- Map.toList (catfuns (abstract pgf)),
+  vcat [ppClauses cat fns | (cat,(_,fs)) <- Map.toList (cats (abstract pgf)),
                             let fns = [(f,fromJust (Map.lookup f (funs (abstract pgf)))) | f <- fs]]
   where
     ppClauses cat fns =
@@ -23,11 +23,11 @@ grammar2lambdaprolog_mod pgf = render $
 grammar2lambdaprolog_sig pgf = render $
   text "sig" <+> ppCId (absname pgf) <> char '.' $$
   space $$
-  vcat [ppCat c hyps <> dot | (c,hyps) <- Map.toList (cats (abstract pgf))] $$
+  vcat [ppCat c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))] $$
   space $$
   vcat [ppFun f ty <> dot | (f,(ty,_,_)) <- Map.toList (funs (abstract pgf))] $$
   space $$
-  vcat [ppExport c hyps <> dot | (c,hyps) <- Map.toList (cats (abstract pgf))]
+  vcat [ppExport c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))]
 
 ppCat :: CId -> [Hypo] -> Doc
 ppCat c hyps = text "kind" <+> ppKind c <+> text "type"
diff --git a/src/compiler/GF/Compile/PGFtoProlog.hs b/src/compiler/GF/Compile/PGFtoProlog.hs
index 896e18934..3a5df0256 100644
--- a/src/compiler/GF/Compile/PGFtoProlog.hs
+++ b/src/compiler/GF/Compile/PGFtoProlog.hs
@@ -51,7 +51,7 @@ clauseHeader hdr clauses = "":hdr:clauses
 -- abstract syntax
 
 plAbstract :: (CId, Abstr) -> [String]
-plAbstract (name, Abstr aflags funs cats _catfuns) =
+plAbstract (name, Abstr aflags funs cats) =
     ["", "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%",
      "%% abstract module: " ++ plp name] ++
     clauseHeader "%% absflag(?Flag, ?Value): flags for abstract syntax"
@@ -63,8 +63,8 @@ plAbstract (name, Abstr aflags funs cats _catfuns) =
     clauseHeader "%% def(?Fun, ?Expr)" 
                      (concatMap plFundef (Map.assocs funs))
 
-plCat :: (CId, [Hypo]) -> String
-plCat (cat, hypos) = plFact "cat" (plTypeWithHypos typ) 
+plCat :: (CId, ([Hypo],[CId])) -> String
+plCat (cat, (hypos,_)) = plFact "cat" (plTypeWithHypos typ) 
     where ((_,subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos
           args = reverse [EFun x | (_,x) <- subst]
           typ = DTyp hypos' cat args
diff --git a/src/compiler/GF/Speech/VoiceXML.hs b/src/compiler/GF/Speech/VoiceXML.hs
index d638e30a8..9511dde23 100644
--- a/src/compiler/GF/Speech/VoiceXML.hs
+++ b/src/compiler/GF/Speech/VoiceXML.hs
@@ -40,7 +40,7 @@ type Skeleton = [(CId, [(CId, [CId])])]
 
 pgfSkeleton :: PGF -> Skeleton
 pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType pgf f))) | f <- fs]) 
-                   | (c,fs) <- Map.toList (catfuns (abstract pgf)),
+                   | (c,(_,fs)) <- Map.toList (cats (abstract pgf)),
                      not (isLiteralCat c)]
 
 --