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.

2026-04-09 04:59:31 -06:00 · 2010-03-24 11:11:55 +00:00
parent 76d155af0e
commit 68482aa7e9
10 changed files with 29 additions and 32 deletions
--- 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
--- 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"
--- 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
--- 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)]

 --
--- a/src/runtime/haskell/PGF.hs
+++ b/src/runtime/haskell/PGF.hs
@@ -315,8 +315,8 @@ browse pgf id = fmap (\def -> (def,producers,consumers)) definition
                                                                                      in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
                   Just (ty,_,Nothing ) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty)
                   Nothing   -> case Map.lookup id (cats (abstract pgf)) of
-                                  Just hyps -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
-                                  Nothing   -> Nothing
+                                  Just (hyps,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)))
+                                  Nothing       -> Nothing

    (producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf))
      where
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -44,7 +44,6 @@ instance Binary Abstr where
           cats <- get
           return (Abstr{ aflags=aflags
                        , funs=funs, cats=cats
-                        , catfuns=Map.empty
                        })
  
 instance Binary Concr where
--- a/src/runtime/haskell/PGF/Data.hs
+++ b/src/runtime/haskell/PGF/Data.hs
@@ -24,10 +24,12 @@ data PGF = PGF {
  }

 data Abstr = Abstr {
-  aflags  :: Map.Map CId Literal,                     -- value of a flag
-  funs    :: Map.Map CId (Type,Int,Maybe [Equation]), -- type, arrity and definition of function
-  cats    :: Map.Map CId [Hypo],                      -- context of a cat
-  catfuns :: Map.Map CId [CId]                        -- funs to a cat (redundant, for fast lookup)
+  aflags  :: Map.Map CId Literal,                     -- ^ value of a flag
+  funs    :: Map.Map CId (Type,Int,Maybe [Equation]), -- ^ type, arrity and definition of function
+  cats    :: Map.Map CId ([Hypo],[CId])               -- ^ 1. context of a category
+                                                      -- ^ 2. functions of a category. The order in the list is important,
+                                                      -- this is the order in which the type singatures are given in the source.
+                                                      -- The termination of the exhaustive generation might depend on this.
  }

 data Concr = Concr {
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -59,7 +59,7 @@ functionsToCat :: PGF -> CId -> [(CId,Type)]
 functionsToCat pgf cat =
  [(f,ty) | f <- fs, Just (ty,_,_) <- [Map.lookup f $ funs $ abstract pgf]]
 where 
-   fs = lookMap [] cat $ catfuns $ abstract pgf
+   (_,fs) = lookMap ([],[]) cat $ cats $ abstract pgf

 missingLins :: PGF -> CId -> [CId]
 missingLins pgf lang = [c | c <- fs, not (hasl c)] where
@@ -72,12 +72,11 @@ hasLin pgf lang f = Map.member f $ lproductions $ lookConcr pgf lang
 restrictPGF :: (CId -> Bool) -> PGF -> PGF
 restrictPGF cond pgf = pgf {
  abstract = abstr {
-    funs = restrict $ funs $ abstr,
-    cats = restrict $ cats $ abstr
+    funs = Map.filterWithKey (\c _ -> cond c) (funs abstr),
+    cats = Map.map (\(hyps,fs) -> (hyps,filter cond fs)) (cats abstr)
    }
  }  ---- restrict concrs also, might be needed
 where
-  restrict = Map.filterWithKey (\c _ -> cond c)
  abstr = abstract pgf

 depth :: Expr -> Int
@@ -142,13 +141,8 @@ _B = mkCId "__gfB"
 _V = mkCId "__gfV"

 updateProductionIndices :: PGF -> PGF
-updateProductionIndices pgf = pgf{ abstract  = updateAbstract (abstract pgf)
-                                 , concretes = fmap updateConcrete (concretes pgf)
-                                 }
+updateProductionIndices pgf = pgf{ concretes = fmap updateConcrete (concretes pgf) }
  where
-    updateAbstract abs =
-      abs{catfuns = Map.mapWithKey (\cat _ -> [f | (f, (DTyp _ c _,_,_)) <- Map.toList (funs abs), c==cat]) (cats abs)}
-
    updateConcrete cnc = 
      let prods0    = filterProductions (productions cnc)
          p_prods   = parseIndex cnc prods0
--- a/src/runtime/haskell/PGF/Printer.hs
+++ b/src/runtime/haskell/PGF/Printer.hs
@@ -28,8 +28,8 @@ ppAbs name a = text "abstract" <+> ppCId name <+> char '{' $$
 ppFlag :: CId -> Literal -> Doc
 ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value ;

-ppCat :: CId -> [Hypo] -> Doc
-ppCat c hyps = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps))
+ppCat :: CId -> ([Hypo],[CId]) -> Doc
+ppCat c (hyps,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps))

 ppFun :: CId -> (Type,Int,Maybe [Equation]) -> Doc
 ppFun f (t,_,Just eqs) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t $$
--- a/src/runtime/haskell/PGF/TypeCheck.hs
+++ b/src/runtime/haskell/PGF/TypeCheck.hs
@@ -88,8 +88,8 @@ instance Functor TcM where

 lookupCatHyps :: CId -> TcM [Hypo]
 lookupCatHyps cat = TcM (\abstr metaid ms -> case Map.lookup cat (cats abstr) of
-                                               Just hyps -> Ok metaid ms hyps
-                                               Nothing   -> Fail (UnknownCat cat))
+                                               Just (hyps,_) -> Ok metaid ms hyps
+                                               Nothing       -> Fail (UnknownCat cat))

 lookupFunType :: CId -> TcM TType
 lookupFunType fun = TcM (\abstr metaid ms -> case Map.lookup fun (funs abstr) of