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

ensure that metavariable IDs are always in sync

Browse Source
This commit is contained in:
Krasimir Angelov
2023-11-27 13:46:21 +01:00
parent 65002fb586
commit eb71557627
1 changed files with 29 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -24,10 +24,12 @@ import GF.Data.Operations(Err(..))
import PGF2.Transactions import PGF2.Transactions
import Control.Monad import Control.Monad
import Control.Monad.State import Control.Monad.State
import Control.Monad.ST
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.List(mapAccumL,sortOn,sortBy) import Data.List(mapAccumL,sortOn,sortBy)
import Data.Maybe(fromMaybe,isNothing) import Data.Maybe(fromMaybe,isNothing)
import Data.STRef
generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
generatePMCFG opts cwd gr cmo@(cm,cmi) generatePMCFG opts cwd gr cmo@(cm,cmi)
@@ -77,12 +79,12 @@ addPMCFG opts cwd gr cmi id info seqs = return (info,seqs)
pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet) pmcfgForm :: Grammar -> Term -> Context -> Type -> SequenceSet -> Check ([Production],SequenceSet)
pmcfgForm gr t ctxt ty seqs = do pmcfgForm gr t ctxt ty seqs = do
res <- runEvalM gr $ do res <- runEvalM gr $ do
((_,ms),args) <- mapAccumM (\(d,ms) (_,_,ty) -> do (_,args) <- mapAccumM (\arg_no (_,_,ty) -> do
let (ms',_,t) = type2metaTerm gr d ms 0 [] ty t <- EvalM (\gr k mt d r msgs -> do (mt,_,t) <- type2metaTerm gr arg_no mt 0 [] ty
k t mt d r msgs)
tnk <- newThunk [] t tnk <- newThunk [] t
return ((d+1,ms'),tnk)) return (arg_no+1,tnk))
(0,Map.empty) ctxt 0 ctxt
sequence_ [newNarrowing i ty | (i,ty) <- Map.toList ms]
v <- eval [] t args v <- eval [] t args
(lins,params) <- flatten v ty ([],[]) (lins,params) <- flatten v ty ([],[])
lins <- fmap reverse $ mapM str2lin lins lins <- fmap reverse $ mapM str2lin lins
@@ -116,34 +118,38 @@ pmcfgForm gr t ctxt ty seqs = do
Nothing -> let seqid = Map.size m Nothing -> let seqid = Map.size m
in (seqid,Map.insert lin seqid m) in (seqid,Map.insert lin seqid m)
type2metaTerm :: SourceGrammar -> Int -> Map.Map MetaId Type -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> (Map.Map MetaId Type,Int,Term) type2metaTerm :: SourceGrammar -> Int -> MetaThunks s -> LIndex -> [(LIndex,(Ident,Type))] -> Type -> ST s (MetaThunks s,Int,Term)
type2metaTerm gr d ms r rs (Sort s) | s == cStr = type2metaTerm gr d ms r rs (Sort s) | s == cStr =
(ms,r+1,TSymCat d r rs) return (ms,r+1,TSymCat d r rs)
type2metaTerm gr d ms r rs (RecType lbls) = type2metaTerm gr d ms r rs (RecType lbls) = do
let ((ms',r'),ass) = mapAccumL (\(ms,r) (lbl,ty) -> case lbl of ((ms',r'),ass) <- mapAccumM (\(ms,r) (lbl,ty) -> case lbl of
LVar j -> ((ms,r),(lbl,(Just ty,TSymVar d j))) LVar j -> return ((ms,r),(lbl,(Just ty,TSymVar d j)))
lbl -> let (ms',r',t) = type2metaTerm gr d ms r rs ty lbl -> do (ms',r',t) <- type2metaTerm gr d ms r rs ty
in ((ms',r'),(lbl,(Just ty,t)))) return ((ms',r'),(lbl,(Just ty,t))))
(ms,r) lbls (ms,r) lbls
in (ms',r',R ass) return (ms',r',R ass)
type2metaTerm gr d ms r rs (Table p q) type2metaTerm gr d ms r rs (Table p q)
| count == 1 = let (ms',r',t) = type2metaTerm gr d ms r rs q | count == 1 = do (ms',r',t) <- type2metaTerm gr d ms r rs q
in (ms',r+(r'-r),T (TTyped p) [(PW,t)]) return (ms',r+(r'-r),T (TTyped p) [(PW,t)])
| otherwise = let pv = varX (length rs+1) | otherwise = do let pv = varX (length rs+1)
delta = r'-r (ms',delta,t) <-
(ms',r',t) = type2metaTerm gr d ms r ((delta,(pv,p)):rs) q fixST $ \(~(_,delta,_)) ->
in (ms',r+delta*count,T (TTyped p) [(PV pv,t)]) do (ms',r',t) <- type2metaTerm gr d ms r ((delta,(pv,p)):rs) q
return (ms',r'-r,t)
return (ms',r+delta*count,T (TTyped p) [(PV pv,t)])
where where
count = case allParamValues gr p of count = case allParamValues gr p of
Ok ts -> length ts Ok ts -> length ts
Bad msg -> error msg Bad msg -> error msg
type2metaTerm gr d ms r rs ty@(QC q) = type2metaTerm gr d ms r rs ty@(QC q) = do
let i = Map.size ms + 1 let i = Map.size ms + 1
in (Map.insert i ty ms,r,Meta i) tnk <- newSTRef (Narrowing i ty)
return (Map.insert i tnk ms,r,Meta i)
type2metaTerm gr d ms r rs ty type2metaTerm gr d ms r rs ty
| Just n <- isTypeInts ty = | Just n <- isTypeInts ty = do
let i = Map.size ms + 1 let i = Map.size ms + 1
in (Map.insert i ty ms,r,Meta i) tnk <- newSTRef (Narrowing i ty)
return (Map.insert i tnk ms,r,Meta i)
flatten (VR as) (RecType lbls) st = do flatten (VR as) (RecType lbls) st = do
foldM collect st lbls foldM collect st lbls