GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

the compiler and the Haskell runtime now support abstract senses

Browse Source
This commit is contained in:
Krasimir Angelov
2018-11-02 14:01:54 +01:00
parent 777028dcd8
commit bf5abe2948
12 changed files with 127 additions and 117 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
src/compiler/GF/Compile/CFGtoPGF.hs
View File

@@ -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])

174
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -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

2
src/compiler/GF/Compile/PGFtoJS.hs
View File

@@ -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]

2
src/compiler/GF/Compile/PGFtoPython.hs
View File

@@ -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

13
src/compiler/GF/Speech/PGFToCFG.hs
View File

@@ -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

2
src/runtime/haskell/PGF/Data.hs
View File

@@ -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

26
src/runtime/haskell/PGF/Forest.hs
View File

@@ -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

3
src/runtime/haskell/PGF/Morphology.hs
View File

@@ -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]

4
src/runtime/haskell/PGF/OldBinary.hs
View File

@@ -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)

2
src/runtime/haskell/PGF/Optimize.hs
View File

@@ -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]

8
src/runtime/haskell/PGF/Parse.hs
View File

@@ -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

4
src/runtime/haskell/PGF/Printer.hs
View File

@@ -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]