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

added the linref construction in GF. The PGF version number is now bumped

Browse Source
This commit is contained in:
kr.angelov
2013-10-30 12:53:36 +00:00
parent 1381d65131
commit 43fb9b3b7a
28 changed files with 267 additions and 102 deletions
Download Patch File Download Diff File Expand all files Collapse all files

24
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -106,8 +106,8 @@ checkCompleteGrammar opts gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc)
return info
_ -> return info
case info of
CncCat (Just (L loc (RecType []))) _ _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
_ -> Bad "no def lin"
CncCat (Just (L loc (RecType []))) _ _ _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
_ -> Bad "no def lin"
case lookupIdent c js of
Ok (AnyInd _ _) -> return js
@@ -129,13 +129,13 @@ checkCompleteGrammar opts gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc)
checkWarn (text "no linearization of" <+> ppIdent c)
AbsCat (Just _) -> case lookupIdent c js of
Ok (AnyInd _ _) -> return js
Ok (CncCat (Just _) _ _ _) -> return js
Ok (CncCat Nothing mt mp mpmcfg) -> do
Ok (CncCat (Just _) _ _ _ _) -> return js
Ok (CncCat Nothing md mr mp mpmcfg) -> do
checkWarn (text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}")
return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp mpmcfg) js
return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) md mr mp mpmcfg) js
_ -> do
checkWarn (text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}")
return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing) js
return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js
_ -> return js
checkCnc js i@(c,info) =
@@ -147,7 +147,7 @@ checkCompleteGrammar opts gr (am,abs) (cm,cnc) = checkIn (ppLocation (msrc cnc)
return $ updateTree (c,CncFun (Just linty) d mn mf) js
_ -> do checkWarn (text "function" <+> ppIdent c <+> text "is not in abstract")
return js
CncCat _ _ _ _ -> case lookupOrigInfo gr (am,c) of
CncCat _ _ _ _ _ -> case lookupOrigInfo gr (am,c) of
Ok _ -> return $ updateTree i js
_ -> do checkWarn (text "category" <+> ppIdent c <+> text "is not in abstract")
return js
@@ -175,7 +175,7 @@ checkInfo opts sgr (m,mo) c info = do
Nothing -> return ()
return (AbsFun (Just (L loc typ)) ma md moper)
CncCat mty mdef mpr mpmcfg -> do
CncCat mty mdef mref mpr mpmcfg -> do
mty <- case mty of
Just (L loc typ) -> chIn loc "linearization type of" $
(if False --flag optNewComp opts
@@ -192,13 +192,19 @@ checkInfo opts sgr (m,mo) c info = do
(def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
return (Just (L loc def))
_ -> return Nothing
mref <- case (mty,mref) of
(Just (L _ typ),Just (L loc ref)) ->
chIn loc "reference linearization of" $ do
(ref,_) <- checkLType gr [] ref (mkFunType [typ] typeStr)
return (Just (L loc ref))
_ -> return Nothing
mpr <- case mpr of
(Just (L loc t)) ->
chIn loc "print name of" $ do
(t,_) <- checkLType gr [] t typeStr
return (Just (L loc t))
_ -> return Nothing
return (CncCat mty mdef mpr mpmcfg)
return (CncCat mty mdef mref mpr mpmcfg)
CncFun mty mt mpr mpmcfg -> do
mt <- case (mty,mt) of

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

@@ -22,7 +22,7 @@ codeSourceModule co (id,mo) = (id,mo{jments = mapTree codj (jments mo)})
codj (c,info) = case info of
ResOper pty pt -> ResOper (codeLTerms co pty) (codeLTerms co pt)
ResOverload es tyts -> ResOverload es [(codeLTerm co ty,codeLTerm co t) | (ty,t) <- tyts]
CncCat mty mt mpr mpmcfg -> CncCat mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg
CncCat mcat mdef mref mpr mpmcfg -> CncCat mcat (codeLTerms co mdef) (codeLTerms co mref) (codeLTerms co mpr) mpmcfg
CncFun mty mt mpr mpmcfg -> CncFun mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg
_ -> info

42
src/compiler/GF/Compile/GeneratePMCFG.hs
View File

@@ -100,27 +100,47 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
newArgs = map getFIds newArgs'
in addFunction env0 newCat fun newArgs
addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L loc term)) mprn Nothing) = do
let pres = protoFCat gr (am,id) lincat
parg = protoFCat gr (identW,cVar) typeStr
addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat))
mdef@(Just (L loc1 def))
mref@(Just (L loc2 ref))
mprn
Nothing) = do
let pcat = protoFCat gr (am,id) lincat
pvar = protoFCat gr (identW,cVar) typeStr
pmcfgEnv0 = emptyPMCFGEnv
lincont = [(Explicit, varStr, typeStr)]
b <- convert opts gr cenv (floc opath loc id) term (lincont,lincat) [parg]
let lincont = [(Explicit, varStr, typeStr)]
b <- convert opts gr cenv (floc opath loc1 id) def (lincont,lincat) [pvar]
let (seqs1,b1) = addSequencesB seqs b
pmcfgEnv1 = foldBM addRule
pmcfgEnv1 = foldBM addLindef
pmcfgEnv0
(goB b1 CNil [])
(pres,[parg])
pmcfg = getPMCFG pmcfgEnv1
when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pres))
seqs1 `seq` pmcfg `seq` return (seqs1,GF.Grammar.CncCat mty mdef mprn (Just pmcfg))
(pcat,[pvar])
let lincont = [(Explicit, varStr, lincat)]
b <- convert opts gr cenv (floc opath loc2 id) ref (lincont,typeStr) [pcat]
let (seqs2,b2) = addSequencesB seqs1 b
pmcfgEnv2 = foldBM addLinref
pmcfgEnv1
(goB b2 CNil [])
(pvar,[pcat])
let pmcfg = getPMCFG pmcfgEnv2
when (verbAtLeast opts Verbose) $ liftIO $ hPutStr stderr ("\n+ "++showIdent id++" "++show (catFactor pcat))
seqs2 `seq` pmcfg `seq` return (seqs2,GF.Grammar.CncCat mty mdef mref mprn (Just pmcfg))
where
addRule lins (newCat', newArgs') env0 =
addLindef lins (newCat', newArgs') env0 =
let [newCat] = getFIds newCat'
!fun = mkArray lins
in addFunction env0 newCat fun [[fidVar]]
addLinref lins (newCat', [newArg']) env0 =
let newArg = getFIds newArg'
!fun = mkArray lins
in addFunction env0 fidVar fun [newArg]
addPMCFG opts gr cenv opath am cm seqs id info = return (seqs, info)
floc opath loc id = maybe (L loc id) (\path->L (External path loc) id) opath

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

@@ -6,7 +6,7 @@ import GF.Compile.GeneratePMCFG
import GF.Compile.GenerateBC
import PGF.CId
import PGF.Data(fidInt,fidFloat,fidString)
import PGF.Data(fidInt,fidFloat,fidString,fidVar)
import PGF.Optimize(updateProductionIndices)
import qualified PGF.Macros as CM
import qualified PGF.Data as C
@@ -67,7 +67,7 @@ mkCanon2pgf opts gr am = do
(ex_seqs,cdefs) <- addMissingPMCFGs
Map.empty
([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
([((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]] ++
Look.allOrigInfos gr cm)
let flags = Map.fromList [(mkCId f,if f == "beam_size" then C.LFlt (read x) else C.LStr x) | (f,x) <- optionsPGF cflags]
@@ -78,7 +78,7 @@ mkCanon2pgf opts gr am = do
ex_seqs_arr = mkMapArray ex_seqs :: Array SeqId Sequence
!(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
!(!fid_cnt2,!productions,!lindefs,!cncfuns)
!(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
= genCncFuns gr am cm ex_seqs_arr seqs cdefs fid_cnt1 cnccats
printnames = genPrintNames cdefs
@@ -86,6 +86,7 @@ mkCanon2pgf opts gr am = do
printnames
cncfuns
lindefs
linrefs
seqs
productions
IntMap.empty
@@ -178,7 +179,7 @@ genCncCats gr am cm cdefs =
in (index, Map.fromList cats)
where
mkCncCats index [] = (index,[])
mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _):cdefs)
mkCncCats index (((m,id),CncCat (Just (L _ lincat)) _ _ _ _):cdefs)
| id == cInt =
let cc = pgfCncCat gr lincat fidInt
(index',cats) = mkCncCats index cdefs
@@ -208,22 +209,24 @@ genCncFuns :: SourceGrammar
-> (FId,
IntMap.IntMap (Set.Set D.Production),
IntMap.IntMap [FunId],
IntMap.IntMap [FunId],
Array FunId D.CncFun)
genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
let (fid_cnt1,funs_cnt1,funs1,lindefs) = mkCncCats cdefs fid_cnt 0 [] 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,array (0,funs_cnt2-1) funs2)
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)
where
mkCncCats [] fid_cnt funs_cnt funs lindefs =
(fid_cnt,funs_cnt,funs,lindefs)
mkCncCats (((m,id),CncCat _ _ _ (Just (PMCFG prods0 funs0))):cdefs) fid_cnt funs_cnt funs lindefs =
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'
mkCncCats (_ :cdefs) fid_cnt funs_cnt funs lindefs =
mkCncCats cdefs fid_cnt funs_cnt funs lindefs
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
mkCncFuns [] fid_cnt funs_cnt funs lindefs crc prods =
(fid_cnt,funs_cnt,funs,prods)
@@ -264,11 +267,20 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
mkLinDefId id = prefixIdent "lindef " id
toLinDef res offs lindefs (Production fid0 funid0 _) =
IntMap.insertWith (++) fid [offs+funid0] lindefs
toLinDef res offs lindefs (Production fid0 funid0 args) =
if args == [[fidVar]]
then IntMap.insertWith (++) fid [offs+funid0] lindefs
else lindefs
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
@@ -299,9 +311,9 @@ genCncFuns gr am cm ex_seqs seqs cdefs fid_cnt cnccats =
genPrintNames cdefs =
Map.fromAscList [(i2i id, name) | ((m,id),info) <- cdefs, name <- prn info]
where
prn (CncFun _ _ (Just (L _ tr)) _) = [flatten tr]
prn (CncCat _ _ (Just (L _ tr)) _) = [flatten tr]
prn _ = []
prn (CncFun _ _ (Just (L _ tr)) _) = [flatten tr]
prn (CncCat _ _ _ (Just (L _ tr)) _) = [flatten tr]
prn _ = []
flatten (K s) = s
flatten (Alts x _) = flatten x

34
src/compiler/GF/Compile/Optimize.hs
View File

@@ -60,7 +60,7 @@ evalInfo opts sgr m c info = do
errIn ("optimizing " ++ showIdent c) $ case info of
CncCat ptyp pde ppr mpmcfg -> do
CncCat ptyp pde pre ppr mpmcfg -> do
pde' <- case (ptyp,pde) of
(Just (L _ typ), Just (L loc de)) -> do
de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
@@ -71,9 +71,19 @@ evalInfo opts sgr m c info = do
return (Just (L loc (factor param c 0 de)))
_ -> return pde -- indirection
pre' <- case (ptyp,pre) of
(Just (L _ typ), Just (L loc re)) -> do
re <- partEval opts gr ([(Explicit, varStr, typ)], typeStr) re
return (Just (L loc (factor param c 0 re)))
(Just (L loc typ), Nothing) -> do
re <- mkLinReference gr typ
re <- partEval opts gr ([(Explicit, varStr, typ)], typeStr) re
return (Just (L loc (factor param c 0 re)))
_ -> return pre -- indirection
ppr' <- evalPrintname gr ppr
return (CncCat ptyp pde' ppr' mpmcfg)
return (CncCat ptyp pde' pre' ppr' mpmcfg)
CncFun (mt@(Just (_,cont,val))) pde ppr mpmcfg -> --trace (prt c) $
eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do
@@ -166,6 +176,26 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
_ | Just _ <- isTypeInts typ -> return $ EInt 0 -- exists in all as first val
_ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ))
mkLinReference :: SourceGrammar -> Type -> Err Term
mkLinReference gr typ =
liftM (Abs Explicit varStr) $
case mkDefField typ (Vr varStr) of
Bad "no string" -> return Empty
x -> x
where
mkDefField ty trm =
case ty of
Table pty ty -> do ps <- allParamValues gr pty
case ps of
[] -> Bad "no string"
(p:ps) -> mkDefField ty (S trm p)
Sort s | s == cStr -> return trm
QC p -> Bad "no string"
RecType rs -> do
msum (map (\(l,ty) -> mkDefField ty (P trm l)) (sortRec rs))
_ | Just _ <- isTypeInts typ -> Bad "no string"
_ -> Bad (render (text "linearization type field cannot be" <+> ppTerm Unqualified 0 typ))
evalPrintname :: SourceGrammar -> Maybe (L Term) -> Err (Maybe (L Term))
evalPrintname gr mpr =
case mpr of

13
src/compiler/GF/Compile/Refresh.hs
View File

@@ -124,9 +124,16 @@ refreshModule (k,sgr) mi@(i,mo)
(k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $
appSTM (mapPairsM (\(L loc t) -> liftM (L loc) (refresh t)) tyts) (initIdStateN k)
return $ (k', (c, ResOverload os tyts'):cs)
CncCat mt (Just (L loc trm)) mn mpmcfg-> do ---- refresh mt, pn
(k',trm') <- refreshTermKN k trm
return $ (k', (c, CncCat mt (Just (L loc trm')) mn mpmcfg):cs)
CncCat mt md mr mn mpmcfg-> do
(k,md) <- case md of
Just (L loc trm) -> do (k,trm) <- refreshTermKN k trm
return (k,Just (L loc trm))
Nothing -> return (k,Nothing)
(k,mr) <- case mr of
Just (L loc trm) -> do (k,trm) <- refreshTermKN k trm
return (k,Just (L loc trm))
Nothing -> return (k,Nothing)
return (k, (c, CncCat mt md mr mn mpmcfg):cs)
CncFun mt (Just (L loc trm)) mn mpmcfg -> do ---- refresh pn
(k',trm') <- refreshTermKN k trm
return $ (k', (c, CncFun mt (Just (L loc trm')) mn mpmcfg):cs)

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

@@ -153,7 +153,7 @@ renameInfo status (m,mi) i info =
ResValue t -> do
t <- renLoc (renameTerm status []) t
return (ResValue t)
CncCat mty mtr mpr mpmcfg -> liftM4 CncCat (renTerm mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
CncCat mcat mdef mref mpr mpmcfg -> liftM5 CncCat (renTerm mcat) (renTerm mdef) (renTerm mref) (renTerm mpr) (return mpmcfg)
CncFun mty mtr mpr mpmcfg -> liftM3 (CncFun mty) (renTerm mtr) (renTerm mpr) (return mpmcfg)
_ -> return info
where

5
src/compiler/GF/Compile/Tags.hs
View File

@@ -36,8 +36,9 @@ getLocalTags x (m,mi) =
maybe (loc "oper-def") mb_def
getLocations (ResOverload _ defs) = list (\(x,y) -> ltype "overload-type" x ++
loc "overload-def" y) defs
getLocations (CncCat mty mdef mprn _) = maybe (loc "lincat") mty ++
maybe (loc "lindef") mdef ++
getLocations (CncCat mty md mr mprn _) = maybe (loc "lincat") mty ++
maybe (loc "lindef") md ++
maybe (loc "linref") mr ++
maybe (loc "printname") mprn
getLocations (CncFun _ mlin mprn _) = maybe (loc "lin") mlin ++
maybe (loc "printname") mprn

6
src/compiler/GF/Compile/Update.hs
View File

@@ -178,7 +178,7 @@ globalizeLoc fpath i =
ResValue t -> ResValue (gl t)
ResOper mt m -> ResOper (fmap gl mt) (fmap gl m)
ResOverload ms os -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
CncCat mc mf mp mpmcfg-> CncCat (fmap gl mc) (fmap gl mf) (fmap gl mp) mpmcfg
CncCat mc md mr mp mpmcfg-> CncCat (fmap gl mc) (fmap gl md) (fmap gl mr) (fmap gl mp) mpmcfg
CncFun m mt md mpmcfg-> CncFun m (fmap gl mt) (fmap gl md) mpmcfg
AnyInd b m -> AnyInd b m
where
@@ -205,8 +205,8 @@ unifyAnyInfo m i j = case (i,j) of
(ResOper mt1 m1, ResOper mt2 m2) ->
liftM2 ResOper (unifMaybeL mt1 mt2) (unifMaybeL m1 m2)
(CncCat mc1 mf1 mp1 mpmcfg1, CncCat mc2 mf2 mp2 mpmcfg2) ->
liftM4 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2) (unifMaybe mpmcfg1 mpmcfg2)
(CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
liftM5 CncCat (unifMaybeL mc1 mc2) (unifMaybeL md1 md2) (unifMaybeL mr1 mr2) (unifMaybeL mp1 mp2) (unifMaybe mpmcfg1 mpmcfg2)
(CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
liftM3 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL md1 md2) (unifMaybe mpmcfg1 mpmcfg2)

4
src/compiler/GF/Grammar/Analyse.hs
View File

@@ -31,7 +31,7 @@ stripInfo i = case i of
ResValue lt -> i ----
ResOper mt md -> ResOper mt Nothing
ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
CncCat mty mte mtf mpmcfg -> CncCat mty Nothing Nothing Nothing
CncCat mty mte _ mtf mpmcfg -> CncCat mty Nothing Nothing Nothing Nothing
CncFun mict mte mtf mpmcfg -> CncFun mict Nothing Nothing Nothing
AnyInd b f -> i
@@ -110,7 +110,7 @@ sizeInfo i = case i of
ResValue lt -> 0
ResOper mt md -> 1 + msize mt + msize md
ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]
CncCat mty mte mtf _ -> 1 + msize mty -- ignoring lindef and printname
CncCat mty _ _ _ _ -> 1 + msize mty -- ignoring lindef, linref and printname
CncFun mict mte mtf _ -> 1 + msize mte -- ignoring type and printname
AnyInd b f -> -1 -- just to ignore these in the size
_ -> 0

4
src/compiler/GF/Grammar/Binary.hs
View File

@@ -116,7 +116,7 @@ instance Binary Info where
put (ResValue x) = putWord8 3 >> put x
put (ResOper x y) = putWord8 4 >> put (x,y)
put (ResOverload x y)= putWord8 5 >> put (x,y)
put (CncCat w x y z) = putWord8 6 >> put (w,x,y,z)
put (CncCat v w x y z)=putWord8 6 >> put (v,w,x,y,z)
put (CncFun w x y z) = putWord8 7 >> put (w,x,y,z)
put (AnyInd x y) = putWord8 8 >> put (x,y)
get = do tag <- getWord8
@@ -127,7 +127,7 @@ instance Binary Info where
3 -> get >>= \x -> return (ResValue x)
4 -> get >>= \(x,y) -> return (ResOper x y)
5 -> get >>= \(x,y) -> return (ResOverload x y)
6 -> get >>= \(w,x,y,z) -> return (CncCat w x y z)
6 -> get >>= \(v,w,x,y,z)->return (CncCat v w x y z)
7 -> get >>= \(w,x,y,z) -> return (CncFun w x y z)
8 -> get >>= \(x,y) -> return (AnyInd x y)
_ -> decodingError

2
src/compiler/GF/Grammar/CF.hs
View File

@@ -102,7 +102,7 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where
_ -> error "empty CF"
cats = [(cat, AbsCat (Just (L NoLoc []))) |
cat <- nub' (concat (map cf2cat rules))] ----notPredef cat
lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
(funs,lins) = unzip (map cf2rule rules)
cf2cat :: CFRule -> [Ident]

4
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -325,8 +325,8 @@ data Info =
| ResOverload [Ident] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited
-- judgements in concrete syntax
| CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) lindef ini'zed,
| CncFun (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) type info added at 'TC'
| CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) lindef ini'zed,
| CncFun (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe PMCFG) -- ^ (/CNC/) type info added at 'TC'
-- indirection to module Ident
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical

34
src/compiler/GF/Grammar/Lexer.hs
View File

@@ -1,4 +1,4 @@
{-# LANGUAGE CPP,MagicHash #-}
{-# LANGUAGE CPP,MagicHash,BangPatterns #-}
{-# LINE 3 "lexer/Lexer.x" #-}
module GF.Grammar.Lexer
@@ -103,6 +103,7 @@ data Token
| T_lin
| T_lincat
| T_lindef
| T_linref
| T_of
| T_open
| T_oper
@@ -187,6 +188,7 @@ resWords = Map.fromList
, b "lin" T_lin
, b "lincat" T_lincat
, b "lindef" T_lindef
, b "linref" T_linref
, b "of" T_of
, b "open" T_open
, b "oper" T_oper
@@ -314,10 +316,10 @@ alexIndexInt16OffAddr (AlexA# arr) off =
#ifdef WORDS_BIGENDIAN
narrow16Int# i
where
i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
low = int2Word# (ord# (indexCharOffAddr# arr off'))
off' = off *# 2#
!i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
!high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
!low = int2Word# (ord# (indexCharOffAddr# arr off'))
!off' = off *# 2#
#else
indexInt16OffAddr# arr off
#endif
@@ -331,14 +333,14 @@ alexIndexInt32OffAddr (AlexA# arr) off =
#ifdef WORDS_BIGENDIAN
narrow32Int# i
where
i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`
!i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`
(b2 `uncheckedShiftL#` 16#) `or#`
(b1 `uncheckedShiftL#` 8#) `or#` b0)
b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))
b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))
b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
b0 = int2Word# (ord# (indexCharOffAddr# arr off'))
off' = off *# 4#
!b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))
!b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))
!b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
!b0 = int2Word# (ord# (indexCharOffAddr# arr off'))
!off' = off *# 4#
#else
indexInt32OffAddr# arr off
#endif
@@ -414,12 +416,12 @@ alex_scan_tkn user orig_input len input s last_acc =
let
(base) = alexIndexInt32OffAddr alex_base s
((I# (ord_c))) = ord c
(offset) = (base +# ord_c)
(check) = alexIndexInt16OffAddr alex_check offset
(!(base)) = alexIndexInt32OffAddr alex_base s
(!((I# (ord_c)))) = ord c
(!(offset)) = (base +# ord_c)
(!(check)) = alexIndexInt16OffAddr alex_check offset
(new_s) = if (offset >=# 0#) && (check ==# ord_c)
(!(new_s)) = if (offset >=# 0#) && (check ==# ord_c)
then alexIndexInt16OffAddr alex_table offset
else alexIndexInt16OffAddr alex_deflt s
in

12
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -74,8 +74,8 @@ lookupResDefLoc gr (m,c)
case info of
ResOper _ (Just lt) -> return lt
ResOper _ Nothing -> return (noLoc (Q (m,c)))
CncCat (Just (L l ty)) _ _ _ -> fmap (L l) (lock c ty)
CncCat _ _ _ _ -> fmap noLoc (lock c defLinType)
CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty)
CncCat _ _ _ _ _ -> fmap noLoc (lock c defLinType)
CncFun (Just (cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
CncFun _ (Just ltr) _ _ -> return ltr
@@ -92,7 +92,7 @@ lookupResType gr (m,c) = do
ResOper (Just (L _ t)) _ -> return t
-- used in reused concrete
CncCat _ _ _ _ -> return typeType
CncCat _ _ _ _ _ -> return typeType
CncFun (Just (cat,cont,val)) _ _ _ -> do
val' <- lock cat val
return $ mkProd cont val' []
@@ -166,9 +166,9 @@ lookupLincat gr m c | isPredefCat c = return defLinType --- ad hoc; not needed?
lookupLincat gr m c = do
info <- lookupQIdentInfo gr (m,c)
case info of
CncCat (Just (L _ t)) _ _ _ -> return t
AnyInd _ n -> lookupLincat gr n c
_ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
CncCat (Just (L _ t)) _ _ _ _ -> return t
AnyInd _ n -> lookupLincat gr n c
_ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
-- | this is needed at compile time
lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type

2
src/compiler/GF/Grammar/Macros.hs
View File

@@ -593,7 +593,7 @@ allDependencies ism b =
ResOper pty pt -> [pty,pt]
ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,cont) <- ps, (_,_,t) <- cont]
CncCat pty _ _ _ -> [pty]
CncCat pty _ _ _ _ -> [pty]
CncFun _ pt _ _ -> [pt] ---- (Maybe (Ident,(Context,Type))
AbsFun pty _ ptr _ -> [pty] --- ptr is def, which can be mutual
AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]

10
src/compiler/GF/Grammar/Parser.y
View File

@@ -85,6 +85,7 @@ import Data.Char(toLower)
'lin' { T_lin }
'lincat' { T_lincat }
'lindef' { T_lindef }
'linref' { T_linref }
'of' { T_of }
'open' { T_open }
'oper' { T_oper }
@@ -221,10 +222,11 @@ TopDef
| 'data' ListDataDef { Left $2 }
| 'param' ListParamDef { Left $2 }
| 'oper' ListOperDef { Left $2 }
| 'lincat' ListTermDef { Left [(f, CncCat (Just e) Nothing Nothing Nothing) | (f,e) <- $2] }
| 'lindef' ListTermDef { Left [(f, CncCat Nothing (Just e) Nothing Nothing) | (f,e) <- $2] }
| 'lincat' ListTermDef { Left [(f, CncCat (Just e) Nothing Nothing Nothing Nothing) | (f,e) <- $2] }
| 'lindef' ListTermDef { Left [(f, CncCat Nothing (Just e) Nothing Nothing Nothing) | (f,e) <- $2] }
| 'linref' ListTermDef { Left [(f, CncCat Nothing Nothing (Just e) Nothing Nothing) | (f,e) <- $2] }
| 'lin' ListLinDef { Left $2 }
| 'printname' 'cat' ListTermDef { Left [(f, CncCat Nothing Nothing (Just e) Nothing) | (f,e) <- $3] }
| 'printname' 'cat' ListTermDef { Left [(f, CncCat Nothing Nothing Nothing (Just e) Nothing) | (f,e) <- $3] }
| 'printname' 'fun' ListTermDef { Left [(f, CncFun Nothing Nothing (Just e) Nothing) | (f,e) <- $3] }
| 'flags' ListFlagDef { Right $2 }
@@ -688,7 +690,7 @@ checkInfoType mt jment@(id,info) =
case info of
AbsCat pcont -> ifAbstract mt (locPerh pcont)
AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
CncCat pty pd ppn _ -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn)
CncCat pty pd pr ppn _->ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh pr ++ locPerh ppn)
CncFun _ pd ppn _ -> ifConcrete mt (locPerh pd ++ locPerh ppn)
ResParam pparam _ -> ifResource mt (locPerh pparam)
ResValue ty -> ifResource mt (locL ty)

9
src/compiler/GF/Grammar/Printer.hs
View File

@@ -124,13 +124,16 @@ ppJudgement q (id, ResOverload ids defs) =
(text "overload" <+> lbrace $$
nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e <+> semi) | (L _ ty,L _ e) <- defs]) $$
rbrace) <+> semi
ppJudgement q (id, CncCat ptype pexp pprn mpmcfg) =
(case ptype of
ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
(case pcat of
Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi
Nothing -> empty) $$
(case pexp of
(case pdef of
Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
Nothing -> empty) $$
(case pref of
Just (L _ exp) -> text "linref" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
Nothing -> empty) $$
(case pprn of
Just (L _ prn) -> text "printname" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
Nothing -> empty) $$

2
src/compiler/GF/Grammar/lexer/Lexer.x
View File

@@ -97,6 +97,7 @@ data Token
| T_lin
| T_lincat
| T_lindef
| T_linref
| T_of
| T_open
| T_oper
@@ -181,6 +182,7 @@ resWords = Map.fromList
, b "lin" T_lin
, b "lincat" T_lincat
, b "lindef" T_lindef
, b "linref" T_linref
, b "of" T_of
, b "open" T_open
, b "oper" T_oper

4
src/compiler/SimpleEditor/Convert.hs
View File

@@ -121,7 +121,7 @@ convCncJment (name,jment) =
ResParam ops _ ->
return $ Pa $ Param i (maybe "" (render . ppParams q . unLoc) ops)
ResValue _ -> return Ignored
CncCat (Just (L _ typ)) Nothing pprn _ -> -- ignores printname !!
CncCat (Just (L _ typ)) Nothing Nothing pprn _ -> -- ignores printname !!
return $ LC $ Lincat i (render $ ppTerm q 0 typ)
ResOper oltyp (Just lterm) -> return $ Op $ Oper lhs rhs
where
@@ -153,7 +153,7 @@ jmentLocation jment =
AbsCat ctxt -> fmap loc ctxt
AbsFun ty _ _ _ -> fmap loc ty
ResParam ops _ -> fmap loc ops
CncCat ty _ _ _ -> fmap loc ty
CncCat ty _ _ _ _ ->fmap loc ty
ResOper ty rhs -> fmap loc rhs `mplus` fmap loc ty
CncFun _ rhs _ _ -> fmap loc rhs
_ -> Nothing

1
src/runtime/c/pgf/data.h
View File

@@ -299,6 +299,7 @@ typedef struct {
struct PgfCCat {
PgfCncCat* cnccat;
PgfCncFuns* lindefs;
PgfCncFuns* linrefs;
size_t n_synprods;
PgfProductionSeq* prods;
float viterbi_prob;

2
src/runtime/c/pgf/parser.c
View File

@@ -611,6 +611,8 @@ pgf_parsing_create_completed(PgfParsing* ps, PgfParseState* state,
{
PgfCCat* cat = gu_new_flex(ps->pool, PgfCCat, fin, 1);
cat->cnccat = conts->ccat->cnccat;
cat->lindefs = conts->ccat->lindefs;
cat->linrefs = conts->ccat->linrefs;
cat->viterbi_prob = viterbi_prob;
cat->fid = ps->max_fid++;
cat->conts = conts;

34
src/runtime/c/pgf/printer.c
View File

@@ -164,9 +164,33 @@ pgf_print_lindefs(GuMapItor* fn, const void* key, void* value,
}
}
static void
pgf_print_linrefs(GuMapItor* fn, const void* key, void* value,
GuExn* err)
{
PgfPrintFn* clo = (PgfPrintFn*) fn;
int fid = *((int *) key);
PgfCCat* ccat = *((PgfCCat**) value);
GuOut *out = clo->out;
if (ccat->linrefs != NULL) {
gu_puts(" ",out,err);
size_t n_linrefs = gu_seq_length(ccat->linrefs);
for (size_t i = 0; i < n_linrefs; i++) {
if (i > 0) gu_putc(' ', out, err);
PgfCncFun* fun = gu_seq_get(ccat->linrefs, PgfCncFun*, i);
gu_printf(out,err,"F%d",fun->funid);
}
gu_printf(out,err," -> C%d\n",fid);
}
}
static void
pgf_print_cncfun(PgfCncFun *cncfun, PgfSequences* sequences,
GuOut *out, GuExn *err)
GuOut *out, GuExn *err)
{
gu_printf(out,err," F%d := (", cncfun->funid);
@@ -321,6 +345,10 @@ pgf_print_concrete(PgfCId cncname, PgfConcr* concr,
PgfPrintFn clo3 = { { pgf_print_lindefs }, out };
gu_map_iter(concr->ccats, &clo3.fn, err);
gu_puts(" linrefs\n", out, err);
PgfPrintFn clo4 = { { pgf_print_linrefs }, out };
gu_map_iter(concr->ccats, &clo4.fn, err);
gu_puts(" lin\n", out, err);
size_t n_funs = gu_seq_length(concr->cncfuns);
for (size_t i = 0; i < n_funs; i++) {
@@ -338,8 +366,8 @@ pgf_print_concrete(PgfCId cncname, PgfConcr* concr,
}
gu_puts(" categories\n", out, err);
PgfPrintFn clo4 = { { pgf_print_cnccat }, out };
gu_map_iter(concr->cnccats, &clo4.fn, err);
PgfPrintFn clo5 = { { pgf_print_cnccat }, out };
gu_map_iter(concr->cnccats, &clo5.fn, err);
gu_puts("}\n", out, err);
}

46
src/runtime/c/pgf/reader.c
View File

@@ -830,6 +830,7 @@ pgf_read_fid(PgfReader* rdr, PgfConcr* concr)
ccat = gu_new(PgfCCat, rdr->opool);
ccat->cnccat = NULL;
ccat->lindefs = NULL;
ccat->linrefs = NULL;
ccat->n_synprods = 0;
ccat->prods = NULL;
ccat->viterbi_prob = 0;
@@ -858,7 +859,7 @@ pgf_read_funid(PgfReader* rdr, PgfConcr* concr)
}
static void
pgf_read_lindefs(PgfReader* rdr, PgfConcr* concr)
pgf_read_lindefs(PgfReader* rdr, PgfAbsFun* abs_lin_fun, PgfConcr* concr)
{
size_t len = pgf_read_len(rdr);
gu_return_on_exn(rdr->err, );
@@ -872,11 +873,33 @@ pgf_read_lindefs(PgfReader* rdr, PgfConcr* concr)
ccat->lindefs = gu_new_seq(PgfCncFun*, n_funs, rdr->opool);
for (size_t j = 0; j < n_funs; j++) {
PgfCncFun* fun = pgf_read_funid(rdr, concr);
fun->absfun = abs_lin_fun;
gu_seq_set(ccat->lindefs, PgfCncFun*, j, fun);
}
}
}
static void
pgf_read_linrefs(PgfReader* rdr, PgfAbsFun* abs_lin_fun, PgfConcr* concr)
{
size_t len = pgf_read_len(rdr);
gu_return_on_exn(rdr->err, );
for (size_t i = 0; i < len; i++) {
PgfCCat* ccat = pgf_read_fid(rdr, concr);
size_t n_funs = pgf_read_len(rdr);
gu_return_on_exn(rdr->err, );
ccat->linrefs = gu_new_seq(PgfCncFun*, n_funs, rdr->opool);
for (size_t j = 0; j < n_funs; j++) {
PgfCncFun* fun = pgf_read_funid(rdr, concr);
fun->absfun = abs_lin_fun;
gu_seq_set(ccat->linrefs, PgfCncFun*, j, fun);
}
}
}
static void
pgf_read_parg(PgfReader* rdr, PgfConcr* concr, PgfPArg* parg)
{
@@ -1000,6 +1023,7 @@ pgf_read_cnccat(PgfReader* rdr, PgfAbstr* abstr, PgfConcr* concr, PgfCId name)
ccat = gu_new(PgfCCat, rdr->opool);
ccat->cnccat = NULL;
ccat->lindefs = NULL;
ccat->linrefs = NULL;
ccat->n_synprods = 0;
ccat->prods = NULL;
ccat->viterbi_prob = 0;
@@ -1123,7 +1147,7 @@ pgf_read_ccat_cb(GuMapItor* fn, const void* key, void* value, GuExn* err)
}
static PgfConcr*
pgf_read_concrete(PgfReader* rdr, PgfAbstr* abstr)
pgf_read_concrete(PgfReader* rdr, PgfAbstr* abstr, PgfAbsFun* abs_lin_fun)
{
PgfConcr* concr = gu_new(PgfConcr, rdr->opool);
@@ -1153,7 +1177,8 @@ pgf_read_concrete(PgfReader* rdr, PgfAbstr* abstr)
gu_new_int_map(PgfCCat*, &gu_null_struct, rdr->opool);
concr->fun_indices = gu_map_type_new(PgfCncFunOverloadMap, rdr->opool);
concr->coerce_idx = gu_map_type_new(PgfCncOverloadMap, rdr->opool);
pgf_read_lindefs(rdr, concr);
pgf_read_lindefs(rdr, abs_lin_fun, concr);
pgf_read_linrefs(rdr, abs_lin_fun, concr);
pgf_read_ccats(rdr, concr);
concr->cnccats = pgf_read_cnccats(rdr, abstr, concr);
concr->callbacks = pgf_new_callbacks_map(concr, rdr->opool);
@@ -1177,10 +1202,21 @@ pgf_read_concretes(PgfReader* rdr, PgfAbstr* abstr)
size_t len = pgf_read_len(rdr);
gu_return_on_exn(rdr->err, NULL);
PgfAbsFun* abs_lin_fun = gu_new(PgfAbsFun, rdr->opool);
abs_lin_fun->name = "_";
abs_lin_fun->type = gu_new(PgfType, rdr->opool);
abs_lin_fun->type->hypos = NULL;
abs_lin_fun->type->cid = "_";
abs_lin_fun->type->n_exprs = 0;
abs_lin_fun->arity = 0;
abs_lin_fun->defns = NULL;
abs_lin_fun->ep.prob = INFINITY;
abs_lin_fun->ep.expr = gu_null_variant;
for (size_t i = 0; i < len; i++) {
PgfConcr* concr = pgf_read_concrete(rdr, abstr);
PgfConcr* concr = pgf_read_concrete(rdr, abstr, abs_lin_fun);
gu_return_on_exn(rdr->err, NULL);
gu_map_put(concretes, concr->name, PgfConcr*, concr);
}

9
src/runtime/haskell/PGF.hs
View File

@@ -32,7 +32,7 @@ module PGF(
showType, readType,
mkType, mkHypo, mkDepHypo, mkImplHypo,
unType,
categories, startCat,
categories, categoryContext, startCat,
-- * Functions
functions, functionsByCat, functionType, missingLins,
@@ -221,6 +221,8 @@ abstractName :: PGF -> Language
-- with the \'cat\' keyword.
categories :: PGF -> [CId]
categoryContext :: PGF -> CId -> Maybe [Hypo]
-- | The start category is defined in the grammar with
-- the \'startcat\' flag. This is usually the sentence category
-- but it is not necessary. Despite that there is a start category
@@ -279,6 +281,11 @@ languageCode pgf lang =
categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))]
categoryContext pgf cat =
case Map.lookup cat (cats (abstract pgf)) of
Just (hypos,_,_) -> Just hypos
Nothing -> Nothing
startCat pgf = DTyp [] (lookStartCat pgf) []
functions pgf = Map.keys (funs (abstract pgf))

7
src/runtime/haskell/PGF/Binary.hs
View File

@@ -14,7 +14,7 @@ import qualified Data.Set as Set
import Control.Monad
pgfMajorVersion, pgfMinorVersion :: Word16
(pgfMajorVersion, pgfMinorVersion) = (1,0)
(pgfMajorVersion, pgfMinorVersion) = (2,0)
instance Binary PGF where
put pgf = do putWord16be pgfMajorVersion
@@ -56,6 +56,7 @@ instance Binary Concr where
putArray2 (sequences cnc)
putArray (cncfuns cnc)
put (lindefs cnc)
put (linrefs cnc)
put (productions cnc)
put (cnccats cnc)
put (totalCats cnc)
@@ -64,11 +65,13 @@ instance Binary Concr where
sequences <- getArray2
cncfuns <- getArray
lindefs <- get
linrefs <- get
productions <- get
cnccats <- get
totalCats <- get
return (Concr{ cflags=cflags, printnames=printnames
, sequences=sequences, cncfuns=cncfuns, lindefs=lindefs
, sequences=sequences, cncfuns=cncfuns
, lindefs=lindefs, linrefs=linrefs
, productions=productions
, pproductions = IntMap.empty
, lproductions = Map.empty

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

@@ -41,6 +41,7 @@ data Concr = Concr {
printnames :: Map.Map CId String, -- printname of a cat or a fun
cncfuns :: Array FunId CncFun,
lindefs :: IntMap.IntMap [FunId],
linrefs :: IntMap.IntMap [FunId],
sequences :: Array SeqId Sequence,
productions :: IntMap.IntMap (Set.Set Production), -- the original productions loaded from the PGF file
pproductions :: IntMap.IntMap (Set.Set Production), -- productions needed for parsing

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

@@ -47,7 +47,9 @@ ppCnc name cnc =
text "productions" $$
nest 2 (vcat [ppProduction (fcat,prod) | (fcat,set) <- IntMap.toList (productions cnc), prod <- Set.toList set]) $$
text "lindefs" $$
nest 2 (vcat (map ppLinDef (IntMap.toList (lindefs cnc)))) $$
nest 2 (vcat (map ppFunList (IntMap.toList (lindefs cnc)))) $$
text "linrefs" $$
nest 2 (vcat (map ppFunList (IntMap.toList (linrefs cnc)))) $$
text "lin" $$
nest 2 (vcat (map ppCncFun (assocs (cncfuns cnc)))) $$
text "sequences" $$
@@ -73,7 +75,7 @@ ppProduction (fid,PConst _ _ ss) =
ppCncFun (funid,CncFun fun arr) =
ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun)
ppLinDef (fid,funids) =
ppFunList (fid,funids) =
ppFId fid <+> text "->" <+> hcat (punctuate comma (map ppFunId funids))
ppSeq (seqid,seq) =