diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs index f9ab8afcf..afc9de41f 100644 --- a/src/compiler/GF/Compile/CFGtoPGF.hs +++ b/src/compiler/GF/Compile/CFGtoPGF.hs @@ -56,7 +56,7 @@ cf2concr cfg = Concr Map.empty Map.empty map mkSequence rules) sequences = listArray (0,Set.size sequences0-1) (Set.toList sequences0) - idFun = CncFun wildCId (listArray (0,0) [seqid]) + idFun = CncFun [wildCId] (listArray (0,0) [seqid]) where seq = listArray (0,0) [SymCat 0 0] seqid = binSearch seq sequences (bounds sequences) @@ -77,7 +77,7 @@ cf2concr cfg = Concr Map.empty Map.empty let args = [PArg [] (cat2arg c) | NonTerminal c <- ruleRhs rule] prod = PApply funid args seqid = binSearch (mkSequence rule) sequences (bounds sequences) - fun = CncFun (mkRuleName rule) (listArray (0,0) [seqid]) + fun = CncFun [mkRuleName rule] (listArray (0,0) [seqid]) funid' = funid+1 in funid' `seq` ((funid',fun:funs),let (c,ps) = ruleLhs rule in [(cat2fid c p, prod) | p <- ps]) diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index cd2e6b8ce..eb127f7bd 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -8,16 +8,13 @@ import GF.Compile.GenerateBC import PGF(CId,mkCId,utf8CId) import PGF.Internal(fidInt,fidFloat,fidString,fidVar) import PGF.Internal(updateProductionIndices) ---import qualified PGF.Macros as CM import qualified PGF.Internal as C -import qualified PGF.Internal as D import GF.Grammar.Predef --import GF.Grammar.Printer import GF.Grammar.Grammar import qualified GF.Grammar.Lookup as Look import qualified GF.Grammar as A import qualified GF.Grammar.Macros as GM ---import GF.Compile.GeneratePMCFG import GF.Infra.Ident import GF.Infra.Option @@ -30,15 +27,15 @@ import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Data.Array.IArray -mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE D.PGF +mkCanon2pgf :: Options -> SourceGrammar -> ModuleName -> IOE C.PGF mkCanon2pgf opts gr am = do (an,abs) <- mkAbstr am cncs <- mapM mkConcr (allConcretes gr am) - return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs)) + return $ updateProductionIndices (C.PGF Map.empty an abs (Map.fromList cncs)) where cenv = resourceValues opts gr - mkAbstr am = return (mi2i am, D.Abstr flags funs cats) + mkAbstr am = return (mi2i am, C.Abstr flags funs cats) where aflags = err (const noOptions) mflags (lookupModule gr am) @@ -78,7 +75,7 @@ mkCanon2pgf opts gr am = do = genCncFuns gr am cm ex_seqs_arr seqs cdefs fid_cnt1 cnccats printnames = genPrintNames cdefs - return (mi2i cm, D.Concr flags + return (mi2i cm, C.Concr flags printnames cncfuns lindefs @@ -189,54 +186,80 @@ genCncFuns :: Grammar -> Array SeqId Sequence -> [(QIdent, Info)] -> FId - -> Map.Map CId D.CncCat + -> Map.Map CId C.CncCat -> (FId, - IntMap.IntMap (Set.Set D.Production), + IntMap.IntMap (Set.Set C.Production), IntMap.IntMap [FunId], IntMap.IntMap [FunId], - Array FunId D.CncFun) + Array FunId C.CncFun) genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats = - let (fid_cnt1,funs_cnt1,funs1,lindefs,linrefs) = mkCncCats cdefs fid_cnt 0 [] IntMap.empty IntMap.empty - (fid_cnt2,funs_cnt2,funs2,prods) = mkCncFuns cdefs fid_cnt1 funs_cnt1 funs1 lindefs Map.empty IntMap.empty - in (fid_cnt2,prods,lindefs,linrefs,array (0,funs_cnt2-1) funs2) + let (fid_cnt1,lindefs,linrefs,fun_st1) = mkCncCats cdefs fid_cnt IntMap.empty IntMap.empty Map.empty + ((fid_cnt2,crc,prods),fun_st2) = mkCncFuns cdefs lindefs ((fid_cnt1,Map.empty,IntMap.empty),fun_st1) + in (fid_cnt2,prods,lindefs,linrefs,array (0,Map.size fun_st2-1) (Map.elems fun_st2)) where - mkCncCats [] fid_cnt funs_cnt funs lindefs linrefs = - (fid_cnt,funs_cnt,funs,lindefs,linrefs) - mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs linrefs = - let !funs_cnt' = let (s_funid, e_funid) = bounds funs0 - in funs_cnt+(e_funid-s_funid+1) - lindefs' = foldl' (toLinDef (am,id) funs_cnt) lindefs prods0 - linrefs' = foldl' (toLinRef (am,id) funs_cnt) linrefs prods0 - funs' = foldl' (toCncFun funs_cnt (m,mkLinDefId id)) funs (assocs funs0) - in mkCncCats cdefs fid_cnt funs_cnt' funs' lindefs' linrefs' - mkCncCats (_ :cdefs) fid_cnt funs_cnt funs lindefs linrefs = - mkCncCats cdefs fid_cnt funs_cnt funs lindefs linrefs + mkCncCats [] fid_cnt lindefs linrefs fun_st = + (fid_cnt,lindefs,linrefs,fun_st) + mkCncCats (((m,id),CncCat _ _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt lindefs linrefs fun_st = + let mseqs = case lookupModule gr m of + Ok (ModInfo{mseqs=Just mseqs}) -> mseqs + _ -> ex_seqs + (lindefs',fun_st1) = foldl' (toLinDef (m,id) funs0 mseqs) (lindefs,fun_st ) prods0 + (linrefs',fun_st2) = foldl' (toLinRef (m,id) funs0 mseqs) (linrefs,fun_st1) prods0 + in mkCncCats cdefs fid_cnt lindefs' linrefs' fun_st2 + mkCncCats (_ :cdefs) fid_cnt lindefs linrefs fun_st = + mkCncCats cdefs fid_cnt lindefs linrefs fun_st - mkCncFuns [] fid_cnt funs_cnt funs lindefs crc prods = - (fid_cnt,funs_cnt,funs,prods) - mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs crc prods = - let ---Ok ty_C = fmap GM.typeForm (Look.lookupFunType gr am id) - ty_C = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id) - !funs_cnt' = let (s_funid, e_funid) = bounds funs0 - in funs_cnt+(e_funid-s_funid+1) - !(fid_cnt',crc',prods') - = foldl' (toProd lindefs ty_C funs_cnt) - (fid_cnt,crc,prods) prods0 - funs' = foldl' (toCncFun funs_cnt (m,id)) funs (assocs funs0) - in mkCncFuns cdefs fid_cnt' funs_cnt' funs' lindefs crc' prods' - mkCncFuns (_ :cdefs) fid_cnt funs_cnt funs lindefs crc prods = - mkCncFuns cdefs fid_cnt funs_cnt funs lindefs crc prods + mkCncFuns [] lindefs st = st + mkCncFuns (((m,id),CncFun _ _ _ (Just (PMCFG prods0 funs0))):cdefs) lindefs st = + let ty_C = err error (\x -> x) $ fmap GM.typeForm (Look.lookupFunType gr am id) + mseqs = case lookupModule gr m of + Ok (ModInfo{mseqs=Just mseqs}) -> mseqs + _ -> ex_seqs + bundles = [([(args0,res0) | Production res0 funid0 args0 <- prods0, funid0==funid],lins) | (funid,lins) <- assocs funs0] + !st' = foldl' (toProd id lindefs mseqs ty_C) st bundles + in mkCncFuns cdefs lindefs st' + mkCncFuns (_ :cdefs) lindefs st = + mkCncFuns cdefs lindefs st - toProd lindefs (ctxt_C,res_C,_) offs st (Production fid0 funid0 args0) = - let !((fid_cnt,crc,prods),args) = mapAccumL mkArg st (zip ctxt_C args0) - set0 = Set.fromList (map (C.PApply (offs+funid0)) (sequence args)) - fid = mkFId res_C fid0 - !prods' = case IntMap.lookup fid prods of - Just set -> IntMap.insert fid (Set.union set0 set) prods - Nothing -> IntMap.insert fid set0 prods - in (fid_cnt,crc,prods') + toLinDef mid funs0 mseqs st@(lindefs,fun_st) (Production res0 funid0 [arg0]) + | arg0 == [fidVar] = + let res = mkFId mid res0 + + lins = amap (newSeqId mseqs) (funs0 ! funid0) + + !funid = Map.size fun_st + !fun_st' = Map.insert ([([C.PArg [] fidVar],res)],lins) (funid, C.CncFun [] lins) fun_st + + !lindefs' = IntMap.insertWith (++) res [funid] lindefs + in (lindefs',fun_st') + toLinDef res funs0 mseqs st _ = st + + toLinRef mid funs0 mseqs st (Production res0 funid0 [arg0]) + | res0 == fidVar = + let arg = map (mkFId mid) arg0 + + lins = amap (newSeqId mseqs) (funs0 ! funid0) + + in foldr (\arg (linrefs,fun_st) -> + let !funid = Map.size fun_st + !fun_st' = Map.insert ([([C.PArg [] arg],fidVar)],lins) (funid, C.CncFun [] lins) fun_st + + !linrefs' = IntMap.insertWith (++) arg [funid] linrefs + in (linrefs',fun_st')) + st arg + toLinRef res funs0 mseqs st _ = st + + toProd id lindefs mseqs (ctxt_C,res_C,_) (prod_st,fun_st) (sigs0,lins0) = + let (prod_st',sigs) = mapAccumL mkCncSig prod_st sigs0 + lins = amap (newSeqId mseqs) lins0 + in addBundle id (prod_st',fun_st) (concat sigs,lins) where - mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s ) = + mkCncSig prod_st (args0,res0) = + let !(prod_st',args) = mapAccumL mkArg prod_st (zip ctxt_C args0) + res = mkFId res_C res0 + in (prod_st',[(args,res) | args <- sequence args]) + + mkArg st@(fid_cnt,crc,prods) ((_,_,ty),fid0s) = case fid0s of [fid0] -> (st,map (flip C.PArg (mkFId arg_C fid0)) ctxt) fid0s -> case Map.lookup fids crc of @@ -246,43 +269,16 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats = in ((fid_cnt+1,crc',prods'),map (flip C.PArg fid_cnt) ctxt) where (hargs_C,arg_C) = GM.catSkeleton ty - ctxt = mapM (mkCtxt lindefs) hargs_C + ctxt = mapM mkCtxt hargs_C fids = map (mkFId arg_C) fid0s - mkLinDefId id = prefixIdent "lindef " id + mkCtxt (_,cat) = + case Map.lookup (i2i cat) cnccats of + Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]] + Nothing -> error "GrammarToPGF.mkCtxt failed" - toLinDef res offs lindefs (Production fid0 funid0 args) = - if args == [[fidVar]] - then IntMap.insertWith (++) fid [offs+funid0] lindefs - else lindefs + newSeqId mseqs i = binSearch (mseqs ! i) seqs (bounds seqs) where - fid = mkFId res fid0 - - toLinRef res offs linrefs (Production fid0 funid0 [fargs]) = - if fid0 == fidVar - then foldr (\fid -> IntMap.insertWith (++) fid [offs+funid0]) linrefs fids - else linrefs - where - fids = map (mkFId res) fargs - - mkFId (_,cat) fid0 = - case Map.lookup (i2i cat) cnccats of - Just (C.CncCat s e _) -> s+fid0 - Nothing -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat) - - mkCtxt lindefs (_,cat) = - case Map.lookup (i2i cat) cnccats of - Just (C.CncCat s e _) -> [(C.fidVar,fid) | fid <- [s..e], Just _ <- [IntMap.lookup fid lindefs]] - Nothing -> error "GrammarToPGF.mkCtxt failed" - - toCncFun offs (m,id) funs (funid0,lins0) = - let mseqs = case lookupModule gr m of - Ok (ModInfo{mseqs=Just mseqs}) -> mseqs - _ -> ex_seqs - in (offs+funid0,C.CncFun (i2i id) (amap (newIndex mseqs) lins0)):funs - where - newIndex mseqs i = binSearch (mseqs ! i) seqs (bounds seqs) - binSearch v arr (i,j) | i <= j = case compare v (arr ! k) of LT -> binSearch v arr (i,k-1) @@ -292,6 +288,24 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats = where k = (i+j) `div` 2 + addBundle id ((fid_cnt,crc,prods),fun_st) bundle@(sigs,lins) = + case Map.lookup bundle fun_st of + Just (funid, C.CncFun funs lins) -> + let !fun_st' = Map.insert bundle (funid, C.CncFun (i2i id:funs) lins) fun_st + !prods' = foldl' (\prods (args,res) -> IntMap.insert res (Set.singleton (C.PApply funid args)) prods) prods sigs + in ((fid_cnt,crc,prods'),fun_st') + Nothing -> + let !funid = Map.size fun_st + !fun_st' = Map.insert bundle (funid, C.CncFun [i2i id] lins) fun_st + !prods' = foldl' (\prods (args,res) -> IntMap.insert res (Set.singleton (C.PApply funid args)) prods) prods sigs + in ((fid_cnt,crc,prods'),fun_st') + + mkFId (_,cat) fid0 = + case Map.lookup (i2i cat) cnccats of + Just (C.CncCat s e _) -> s+fid0 + Nothing -> error ("GrammarToPGF.mkFId: missing category "++showIdent cat) + + genPrintNames cdefs = Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info] where diff --git a/src/compiler/GF/Compile/PGFtoJS.hs b/src/compiler/GF/Compile/PGFtoJS.hs index 050a3f658..0fc898aab 100644 --- a/src/compiler/GF/Compile/PGFtoJS.hs +++ b/src/compiler/GF/Compile/PGFtoJS.hs @@ -78,7 +78,7 @@ frule2js (PCoerce arg) = new "Coerce" [JS.EInt arg] farg2js (PArg hypos fid) = new "PArg" (map (JS.EInt . snd) hypos ++ [JS.EInt fid]) -ffun2js (CncFun f lins) = new "CncFun" [JS.EStr (showCId f), JS.EArray (map JS.EInt (Array.elems lins))] +ffun2js (CncFun fns lins) = new "CncFun" [JS.EArray (map (JS.EStr . showCId) fns), JS.EArray (map JS.EInt (Array.elems lins))] seq2js :: Array.Array DotPos Symbol -> JS.Expr seq2js seq = JS.EArray [sym2js s | s <- Array.elems seq] diff --git a/src/compiler/GF/Compile/PGFtoPython.hs b/src/compiler/GF/Compile/PGFtoPython.hs index 379a71598..f977abead 100644 --- a/src/compiler/GF/Compile/PGFtoPython.hs +++ b/src/compiler/GF/Compile/PGFtoPython.hs @@ -62,7 +62,7 @@ pyConcrete cnc = pyDict 3 pyStr id [ ] where pyProds prods = pyList 5 pyProduction (Set.toList prods) pyCncCat (CncCat start end _) = pyList 0 pyCat [start..end] - pyCncFun (CncFun f lins) = pyTuple 0 id [pyList 0 pySeq (Array.elems lins), pyCId f] + pyCncFun (CncFun fns lins) = pyTuple 0 id [pyList 0 pySeq (Array.elems lins), pyList 0 pyCId fns] pySymbols syms = pyList 0 pySymbol (Array.elems syms) pyProduction :: Production -> String diff --git a/src/compiler/GF/Speech/PGFToCFG.hs b/src/compiler/GF/Speech/PGFToCFG.hs index 8cb01f3a9..a63dc43e4 100644 --- a/src/compiler/GF/Speech/PGFToCFG.hs +++ b/src/compiler/GF/Speech/PGFToCFG.hs @@ -74,12 +74,15 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co ruleToCFRule :: (FId,Production) -> [CFRule] ruleToCFRule (c,PApply funid args) = - [Rule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]]) + [Rule (fcatToCat c l) (mkRhs row) term | (l,seqid) <- Array.assocs rhs , let row = sequences cnc ! seqid - , not (containsLiterals row)] + , not (containsLiterals row) + , f <- fns + , let term = profilesToTerm f [fixProfile row n | n <- [0..length args-1]] + ] where - CncFun f rhs = cncfuns cnc ! funid + CncFun fns rhs = cncfuns cnc ! funid mkRhs :: Array DotPos Symbol -> [CFSymbol] mkRhs = concatMap symbolToCFSymbol . Array.elems @@ -111,8 +114,8 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co getPos (SymLit j _) = [j] getPos _ = [] - profilesToTerm :: [Profile] -> CFTerm - profilesToTerm ps = CFObj f (zipWith profileToTerm argTypes ps) + profilesToTerm :: CId -> [Profile] -> CFTerm + profilesToTerm f ps = CFObj f (zipWith profileToTerm argTypes ps) where (argTypes,_) = catSkeleton $ lookType (abstract pgf) f profileToTerm :: CId -> Profile -> CFTerm diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs index 6a0714faf..e85ee5aa2 100644 --- a/src/runtime/haskell/PGF/Data.hs +++ b/src/runtime/haskell/PGF/Data.hs @@ -74,7 +74,7 @@ data Production deriving (Eq,Ord,Show) data PArg = PArg [(FId,FId)] {-# UNPACK #-} !FId deriving (Eq,Ord,Show) data CncCat = CncCat {-# UNPACK #-} !FId {-# UNPACK #-} !FId {-# UNPACK #-} !(Array LIndex String) -data CncFun = CncFun CId {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,Show) +data CncFun = CncFun [CId] {-# UNPACK #-} !(UArray LIndex SeqId) deriving (Eq,Ord,Show) type Sequence = Array DotPos Symbol type FunId = Int type SeqId = Int diff --git a/src/runtime/haskell/PGF/Forest.hs b/src/runtime/haskell/PGF/Forest.hs index 2a680b7c9..f25bc05d7 100644 --- a/src/runtime/haskell/PGF/Forest.hs +++ b/src/runtime/haskell/PGF/Forest.hs @@ -71,10 +71,10 @@ bracketedTokn dp f@(Forest abs cnc forest root) = in (ct,fid',fun,es,(map getVar hypos,lin)) Nothing -> error ("wrong forest id " ++ show fid) where - descend forest (PApply funid args) = let (CncFun fun _lins) = cncfuns cnc ! funid - cat = case isLindefCId fun of - Just cat -> cat - Nothing -> case Map.lookup fun (funs abs) of + descend forest (PApply funid args) = let (CncFun pfuns _lins) = cncfuns cnc ! funid + cat = case pfuns of + [] -> wildCId + (pfun:_) -> case Map.lookup pfun (funs abs) of Just (DTyp _ cat _,_,_,_) -> cat largs = map (render forest) args ltable = mkLinTable cnc isTrusted [] funid largs @@ -103,14 +103,6 @@ bracketedTokn dp f@(Forest abs cnc forest root) = descend (PCoerce fid) = trustedSpots parents' (PArg [] fid) descend (PConst c e _) = IntSet.empty -isLindefCId id - | take l s == lindef = Just (mkCId (drop l s)) - | otherwise = Nothing - where - s = showCId id - lindef = "lindef " - l = length lindef - -- | This function extracts the list of all completed parse trees -- that spans the whole input consumed so far. The trees are also -- limited by the category specified, which is usually @@ -132,13 +124,13 @@ getAbsTrees (Forest abs cnc forest root) arg@(PArg _ fid) ty dp = | otherwise = do fid0 <- get put fid x <- foldForest (\funid args trees -> - do let CncFun fn _lins = cncfuns cnc ! funid - case isLindefCId fn of - Just _ -> do arg <- go (Set.insert fid rec_) scope mb_tty (head args) + do let CncFun fns _lins = cncfuns cnc ! funid + case fns of + [] -> do arg <- go (Set.insert fid rec_) scope mb_tty (head args) return (mkAbs arg) - Nothing -> do ty_fn <- lookupFunType fn + fns -> do ty_fn <- lookupFunType (head fns) (e,tty0) <- foldM (\(e1,tty) arg -> goArg (Set.insert fid rec_) scope fid e1 arg tty) - (EFun fn,TTyp [] ty_fn) args + (EFun (head fns),TTyp [] ty_fn) args case mb_tty of Just tty -> do i <- newGuardedMeta e eqType scope (scopeSize scope) i tty tty0 diff --git a/src/runtime/haskell/PGF/Morphology.hs b/src/runtime/haskell/PGF/Morphology.hs index 2da6da44e..9907d9fa6 100644 --- a/src/runtime/haskell/PGF/Morphology.hs +++ b/src/runtime/haskell/PGF/Morphology.hs @@ -31,7 +31,8 @@ collectWords pinfo = Map.fromListWith (++) [(t, [(fun,lbls ! l)]) | (CncCat s e lbls) <- Map.elems (cnccats pinfo) , fid <- [s..e] , PApply funid _ <- maybe [] Set.toList (IntMap.lookup fid (productions pinfo)) - , let CncFun fun lins = cncfuns pinfo ! funid + , let CncFun funs lins = cncfuns pinfo ! funid + , fun <- funs , (l,seqid) <- assocs lins , sym <- elems (sequences pinfo ! seqid) , t <- sym2tokns sym] diff --git a/src/runtime/haskell/PGF/OldBinary.hs b/src/runtime/haskell/PGF/OldBinary.hs index c727589f5..6acc18895 100644 --- a/src/runtime/haskell/PGF/OldBinary.hs +++ b/src/runtime/haskell/PGF/OldBinary.hs @@ -60,7 +60,7 @@ getConcr = cnccats <- getMap getCId getCncCat totalCats <- get let rseq = listToArray [SymCat 0 0] - rfun = CncFun (mkCId "linref") (listToArray [scnt]) + rfun = CncFun [mkCId "linref"] (listToArray [scnt]) linrefs = IntMap.fromList [(i,[fcnt])|i<-[0..totalCats-1]] return (Concr{ cflags=cflags, printnames=printnames , sequences=toArray (scnt+1,seqs++[rseq]) @@ -110,7 +110,7 @@ getBindType = 1 -> return Implicit _ -> decodingError "getBindType" -getCncFun = liftM2 CncFun getCId (getArray get) +getCncFun = liftM2 CncFun (fmap (:[]) getCId) (getArray get) getCncCat = liftM3 CncCat get get (getArray get) diff --git a/src/runtime/haskell/PGF/Optimize.hs b/src/runtime/haskell/PGF/Optimize.hs index 6e7f51fb2..0573c5bf4 100644 --- a/src/runtime/haskell/PGF/Optimize.hs +++ b/src/runtime/haskell/PGF/Optimize.hs @@ -253,7 +253,7 @@ updateConcrete abs cnc = , prod <- Set.toList prods , fun <- getFunctions prod] where - getFunctions (PApply funid args) = let CncFun fun _ = cncfuns cnc ! funid in [fun] + getFunctions (PApply funid args) = let CncFun funs _ = cncfuns cnc ! funid in funs getFunctions (PCoerce fid) = case IntMap.lookup fid productions of Nothing -> [] Just prods -> [fun | prod <- Set.toList prods, fun <- getFunctions prod] diff --git a/src/runtime/haskell/PGF/Parse.hs b/src/runtime/haskell/PGF/Parse.hs index 51b1d3273..c27cefba8 100644 --- a/src/runtime/haskell/PGF/Parse.hs +++ b/src/runtime/haskell/PGF/Parse.hs @@ -503,14 +503,14 @@ type Continuation = TrieMap.TrieMap Token ActiveSet -- | Return the Continuation of a Parsestate with exportable types -- Used by PGFService getContinuationInfo :: ParseState -> Map.Map [Token] [(FunId, CId, String)] -getContinuationInfo pstate = Map.map (map f . Set.toList) contMap +getContinuationInfo pstate = Map.map (concatMap f . Set.toList) contMap where PState _abstr concr _chart cont = pstate contMap = Map.fromList (TrieMap.toList cont) -- always get [([], _::ActiveSet)] - f :: Active -> (FunId,CId,String) - f (Active int dotpos funid seqid pargs ak) = (funid, cid, seq) + f :: Active -> [(FunId,CId,String)] + f (Active int dotpos funid seqid pargs ak) = [(funid, fn, seq) | fn <- fns] where - CncFun cid _ = cncfuns concr ! funid + CncFun fns _ = cncfuns concr ! funid seq = showSeq dotpos (sequences concr ! seqid) showSeq :: DotPos -> Sequence -> String diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs index 07e94f866..3501f49b0 100644 --- a/src/runtime/haskell/PGF/Printer.hs +++ b/src/runtime/haskell/PGF/Printer.hs @@ -73,8 +73,8 @@ ppProduction (fid,PCoerce arg) = ppProduction (fid,PConst _ _ ss) = ppFId fid <+> text "->" <+> ppStrs ss -ppCncFun (funid,CncFun fun arr) = - ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun) +ppCncFun (funid,CncFun funs arr) = + ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (hsep (map ppCId funs)) ppLinDefs (fid,funids) = [ppFId fid <+> text "->" <+> ppFunId funid <> brackets (ppFId fidVar) | funid <- funids]