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

we can finally compile the English RGL

Browse Source
This commit is contained in:
krangelov
2021-10-20 19:39:02 +02:00
parent ad3489f0f9
commit b6047463a9
5 changed files with 254 additions and 146 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -13,7 +13,7 @@ module GF.Compile.GeneratePMCFG
(generatePMCFG, pgfCncCat, addPMCFG
) where
import GF.Grammar hiding (VApp)
import GF.Grammar hiding (VApp,VRecType)
import GF.Grammar.Predef
import GF.Grammar.Lookup
import GF.Infra.CheckM
@@ -46,7 +46,7 @@ pmcfgForm gr t ctxt ty =
tnk <- newThunk [] t
return ((d+1,ms'),tnk))
(0,Map.empty) ctxt
sequence_ [newMeta (Just ty) i | (i,ty) <- Map.toList ms]
sequence_ [newNarrowing i ty | (i,ty) <- Map.toList ms]
v <- eval [] t args
(lins,params) <- flatten v ty ([],[])
lins <- mapM str2lin lins
@@ -55,7 +55,7 @@ pmcfgForm gr t ctxt ty =
return (PMCFGRule (PMCFGCat r rs) args (reverse lins))
where
tnk2pmcfgcat tnk (_,_,ty) = do
v <- force tnk []
v <- force tnk
(_,params) <- flatten v ty ([],[])
(r,rs,_) <- compute params
return (PMCFGCat r rs)
@@ -85,26 +85,12 @@ type2metaTerm gr d ms r rs ty@(QC q) =
let i = Map.size ms + 1
in (Map.insert i ty ms,r,Meta i)
flatten (VSusp tnk env vs k) ty st = do
tnk_st <- getMeta tnk
case tnk_st of
Evaluated v -> do v <- apply v vs
flatten v ty st
Unbound (Just (QC q)) _ -> do (m,ResParam (Just (L _ ps)) _) <- getInfo q
msum [bind tnk m p | p <- ps]
v <- k tnk
flatten v ty st
where
bind tnk m (p, ctxt) = do
tnks <- mapM (\(_,_,ty) -> newMeta (Just ty) 0) ctxt
setMeta tnk (Evaluated (VApp (m,p) tnks))
flatten (VR as) (RecType lbls) st = do
foldM collect st lbls
where
collect st (lbl,ty) =
case lookup lbl as of
Just tnk -> do v <- force tnk []
Just tnk -> do v <- force tnk
flatten v ty st
Nothing -> evalError ("Missing value for label" <+> pp lbl $$
"among" <+> hsep (punctuate (pp ',') (map fst as)))
@@ -121,25 +107,36 @@ flatten (VV _ tnks) (Table _ q) st = do
foldM collect st tnks
where
collect st tnk = do
v <- force tnk []
v <- force tnk
flatten v q st
flatten v (Sort s) (lins,params) | s == cStr = do
return (v:lins,params)
flatten v (QC q) (lins,params) = do
return (lins,v:params)
flatten v _ _ = do
error (showValue v)
str2lin (VApp q [])
| q == (cPredef, cBIND) = return [SymBIND]
| q == (cPredef, cNonExist) = return [SymNE]
| q == (cPredef, cSOFT_BIND) = return [SymSOFT_BIND]
| q == (cPredef, cSOFT_SPACE) = return [SymSOFT_SPACE]
| q == (cPredef, cCAPIT) = return [SymCAPIT]
| q == (cPredef, cALL_CAPIT) = return [SymALL_CAPIT]
str2lin (VStr s) = return [SymKS s]
str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
return [SymCat d r rs]
where
compute r' [] = return (r',[])
compute r' ((cnt',tnk):tnks) = do
(r, rs,_) <- force tnk [] >>= param2int
(r, rs,_) <- force tnk >>= param2int
(r',rs' ) <- compute r' tnks
return (r*cnt'+r',combine cnt' rs rs')
str2lin (VC vs) = fmap concat (mapM str2lin vs)
str2lin (VAlts def alts) = do def <- str2lin def
return [SymKP def []]
str2lin v = do t <- value2term 0 v
evalError ("the term" <+> ppTerm Unqualified 0 t $$
evalError ("the string:" <+> ppTerm Unqualified 0 t $$
"cannot be evaluated at compile time.")
param2int (VApp q tnks) = do
@@ -155,16 +152,19 @@ param2int (VApp q tnks) = do
compute [] = return (0,[],1)
compute (tnk:tnks) = do
(r, rs ,cnt ) <- force tnk [] >>= param2int
(r, rs ,cnt ) <- force tnk >>= param2int
(r',rs',cnt') <- compute tnks
return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
param2int (VMeta tnk _ _) = do
tnk_st <- getMeta tnk
tnk_st <- getRef tnk
case tnk_st of
Evaluated v -> param2int v
Unbound (Just ty) j -> do let QC q = valTypeCnc ty
(_,ResParam _ (Just (_,cnt))) <- getInfo q
return (0,[(1,j)],cnt)
Evaluated v -> param2int v
Narrowing j ty -> do let QC q = valTypeCnc ty
(_,ResParam _ (Just (_,cnt))) <- getInfo q
return (0,[(1,j)],cnt)
param2int v = do t <- value2term 0 v
evalError ("the parameter:" <+> ppTerm Unqualified 0 t $$
"cannot be evaluated at compile time.")
combine cnt' [] rs' = rs'
combine cnt' rs [] = [(r*cnt',pv) | (r,pv) <- rs]