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)] -- diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index d27abd76c..c16f2a88c 100644 --- 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 diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index d03349fc7..241c9cc99 100644 --- 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 diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs index fe768cd20..b604317fc 100644 --- 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 { diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs index 34f32c386..d7f242c45 100644 --- 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 diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs index 23bdc718d..1d9928304 100644 --- 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 $$ diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs index 2e34bc31c..3a95fc611 100644 --- 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