GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-19 16:12:52 -06:00
Code Issues Packages Projects Releases Wiki Activity

first steps towards PMCFG generation

Browse Source
This commit is contained in:
krangelov
2021-10-08 11:53:07 +02:00
parent e33d881ce8
commit 98f42051b1
14 changed files with 142 additions and 969 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -23,10 +23,10 @@ import GF.Infra.UseIO(MonadIO(..))
import GF.Grammar.Grammar
import PGF2(Literal(..))
import PGF2.Internal(Symbol(..))
import PGF2.Transactions(Symbol(..))
-- Please change this every time when the GFO format is changed
gfoVersion = "GF04"
gfoVersion = "GF05"
instance Binary Ident where
put id = put (ident2utf8 id)
@@ -44,9 +44,9 @@ instance Binary Grammar where
get = fmap mGrammar get
instance Binary ModuleInfo where
put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,mseqs mi,jments mi)
get = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,mseqs,jments) <- get
return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc mseqs jments)
put mi = do put (mtype mi,mstatus mi,mflags mi,mextend mi,mwith mi,mopens mi,mexdeps mi,msrc mi,jments mi)
get = do (mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc,jments) <- get
return (ModInfo mtype mstatus mflags mextend mwith mopens med msrc jments)
instance Binary ModuleType where
put MTAbstract = putWord8 0
@@ -103,18 +103,9 @@ instance Binary Options where
toString (LInt n) = show n
toString (LFlt d) = show d
instance Binary Production where
put (Production res funid args) = put (res,funid,args)
get = do res <- get
funid <- get
args <- get
return (Production res funid args)
instance Binary PMCFG where
put (PMCFG prods funs) = put (prods,funs)
get = do prods <- get
funs <- get
return (PMCFG prods funs)
put (PMCFG lins) = put lins
get = fmap PMCFG get
instance Binary Info where
put (AbsCat x) = putWord8 0 >> put x
@@ -377,7 +368,7 @@ decodeModuleHeader :: MonadIO io => FilePath -> io (VersionTagged Module)
decodeModuleHeader = liftIO . fmap (fmap conv) . decodeFile'
where
conv (m,mtype,mstatus,mflags,mextend,mwith,mopens,med,msrc) =
(m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Nothing Map.empty)
(m,ModInfo mtype mstatus mflags mextend mwith mopens med msrc Map.empty)
encodeModule :: MonadIO io => FilePath -> SourceModule -> io ()
encodeModule fpath mo = liftIO $ encodeFile fpath (Tagged mo)

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

@@ -8,7 +8,7 @@ module GF.Grammar.CFG(Cat,Token, module GF.Grammar.CFG) where
import GF.Data.Utilities
import PGF2(Fun,Cat)
import PGF2.Internal(Token)
import PGF2.Transactions(Token)
import GF.Data.Relation
import Data.Map (Map)

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

@@ -64,7 +64,7 @@ module GF.Grammar.Grammar (
Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
-- ** PMCFG
PMCFG(..), Production(..), FId, FunId, SeqId, LIndex
PMCFG(..)
) where
import GF.Infra.Ident
@@ -74,7 +74,7 @@ import GF.Infra.Location
import GF.Data.Operations
import PGF2(BindType(..))
import PGF2.Internal(FId, FunId, SeqId, LIndex, Symbol)
import PGF2.Transactions(Symbol)
import Data.Array.IArray(Array)
import Data.Array.Unboxed(UArray)
@@ -100,7 +100,6 @@ data ModuleInfo = ModInfo {
mopens :: [OpenSpec],
mexdeps :: [ModuleName],
msrc :: FilePath,
mseqs :: Maybe (Array SeqId [Symbol]),
jments :: Map.Map Ident Info
}
@@ -305,13 +304,7 @@ allConcreteModules gr =
[i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
data Production = Production {-# UNPACK #-} !FId
{-# UNPACK #-} !FunId
[[FId]]
deriving (Eq,Ord,Show)
data PMCFG = PMCFG [Production]
(Array FunId (UArray LIndex SeqId))
data PMCFG = PMCFG [[[Symbol]]]
deriving (Eq,Show)
-- | the constructors are judgements in

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

@@ -132,14 +132,14 @@ ModDef
(opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
jments <- mapM (checkInfoType mtype) jments
defs <- buildAnyTree id jments
return (id, ModInfo mtype mstat opts extends with opens [] "" Nothing defs) }
return (id, ModInfo mtype mstat opts extends with opens [] "" defs) }
ModHeader :: { SourceModule }
ModHeader
: ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
(mtype,id) = $2 ;
(extends,with,opens) = $4 }
in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) }
in (id, ModInfo mtype mstat noOptions extends with opens [] "" Map.empty) }
ComplMod :: { ModuleStatus }
ComplMod

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

@@ -25,7 +25,7 @@ module GF.Grammar.Printer
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import PGF2 as PGF2
import PGF2.Internal as PGF2
import PGF2.Transactions as PGF2
import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.Values
@@ -46,11 +46,10 @@ instance Pretty Grammar where
pp = vcat . map (ppModule Qualified) . modules
ppModule :: TermPrintQual -> SourceModule -> Doc
ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ jments) =
hdr $$
nest 2 (ppOptions opts $$
vcat (map (ppJudgement q) (Map.toList jments)) $$
maybe empty (ppSequences q) mseqs) $$
vcat (map (ppJudgement q) (Map.toList jments))) $$
ftr
where
hdr = complModDoc <+> modTypeDoc <+> '=' <+>
@@ -136,13 +135,9 @@ ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
Nothing -> empty) $$
(case (mpmcfg,q) of
(Just (PMCFG prods funs),Internal)
(Just (PMCFG lins),Internal)
-> "pmcfg" <+> id <+> '=' <+> '{' $$
nest 2 (vcat (map ppProduction prods) $$
' ' $$
vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
(Array.assocs funs))) $$
nest 2 (vcat (map ppPmcfgLin lins)) $$
'}'
_ -> empty)
ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
@@ -154,13 +149,9 @@ ppJudgement q (id, CncFun ptype pdef pprn mpmcfg) =
Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
Nothing -> empty) $$
(case (mpmcfg,q) of
(Just (PMCFG prods funs),Internal)
(Just (PMCFG lins),Internal)
-> "pmcfg" <+> id <+> '=' <+> '{' $$
nest 2 (vcat (map ppProduction prods) $$
' ' $$
vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
(Array.assocs funs))) $$
nest 2 (vcat (map ppPmcfgLin lins)) $$
'}'
_ -> empty)
ppJudgement q (id, AnyInd cann mid) =
@@ -168,6 +159,9 @@ ppJudgement q (id, AnyInd cann mid) =
Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
_ -> empty
ppPmcfgLin lin =
brackets (vcat (map (hsep . map ppSymbol) lin))
instance Pretty Term where pp = ppTerm Unqualified 0
ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e)
@@ -330,18 +324,6 @@ ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
ppProduction (Production fid funid args) =
ppFId fid <+> "->" <+> ppFunId funid <>
brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
ppSequences q seqsArr
| null seqs || q /= Internal = empty
| otherwise = "sequences" <+> '{' $$
nest 2 (vcat (map ppSeq seqs)) $$
'}'
where
seqs = Array.assocs seqsArr
commaPunct f ds = (hcat (punctuate "," (map f ds)))
prec d1 d2 doc
@@ -365,17 +347,6 @@ getLet (Let l e) = let (ls,e') = getLet e
in (l:ls,e')
getLet e = ([],e)
ppFunId funid = pp 'F' <> pp funid
ppSeqId seqid = pp 'S' <> pp seqid
ppFId fid
| fid == PGF2.fidString = pp "CString"
| fid == PGF2.fidInt = pp "CInt"
| fid == PGF2.fidFloat = pp "CFloat"
| fid == PGF2.fidVar = pp "CVar"
| fid == PGF2.fidStart = pp "CStart"
| otherwise = pp 'C' <> pp fid
ppMeta :: Int -> Doc
ppMeta n
| n == 0 = pp '?'
@@ -385,9 +356,6 @@ ppLit (PGF2.LStr s) = pp (show s)
ppLit (PGF2.LInt n) = pp n
ppLit (PGF2.LFlt d) = pp d
ppSeq (seqid,seq) =
ppSeqId seqid <+> pp ":=" <+> hsep (map ppSymbol seq)
ppSymbol (PGF2.SymCat d r) = pp '<' <> pp d <> pp ',' <> pp r <> pp '>'
ppSymbol (PGF2.SymLit d r) = pp '{' <> pp d <> pp ',' <> pp r <> pp '}'
ppSymbol (PGF2.SymVar d r) = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'