mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-29 06:22:51 -06:00
working PMCFG generation
This commit is contained in:
krangelov
@@ -25,7 +25,6 @@ import PGF2.Transactions
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Control.Monad
|
||||
import Data.List(mapAccumL)
|
||||
import Debug.Trace
|
||||
|
||||
generatePMCFG :: Options -> FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
|
||||
generatePMCFG opts cwd gr cmo@(cm,cmi) = do
|
||||
@@ -33,24 +32,39 @@ generatePMCFG opts cwd gr cmo@(cm,cmi) = do
|
||||
js <- mapM (addPMCFG opts cwd gr' cmi) (Map.toList (jments cmi))
|
||||
return (cm,cmi{jments = (Map.fromAscList js)})
|
||||
|
||||
addPMCFG opts cwd gr cmi (id,CncFun mty@(Just (cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) =
|
||||
addPMCFG opts cwd gr cmi (id,CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L loc term)) mprn Nothing) =
|
||||
checkInModule cwd cmi loc ("Happened in the PMCFG generation for" <+> id) $ do
|
||||
lins <- pmcfgForm gr (L loc id) term ctxt
|
||||
return (id,CncFun mty mlin mprn (Just (PMCFG lins)))
|
||||
rules <- pmcfgForm gr term ctxt val
|
||||
return (id,CncFun mty mlin mprn (Just rules))
|
||||
addPMCFG opts cwd gr cmi id_info = return id_info
|
||||
|
||||
pmcfgForm :: Grammar -> L Ident -> Term -> Context -> Check [[[Symbol]]]
|
||||
pmcfgForm gr _ t ctxt =
|
||||
pmcfgForm :: Grammar -> Term -> Context -> Type -> Check [PMCFGRule]
|
||||
pmcfgForm gr t ctxt ty =
|
||||
runEvalM gr $ do
|
||||
((_,ms),args) <- mapAccumM (\(d,ms) (_,_,ty) -> do
|
||||
let (ms',_,t) = type2metaTerm gr d ms 0 [] ty
|
||||
tnk <- trace (show (ppTerm Unqualified 0 t)) $ newThunk [] t
|
||||
tnk <- newThunk [] t
|
||||
return ((d+1,ms'),tnk))
|
||||
(0,Map.empty) ctxt
|
||||
sequence_ [newMeta (Just ty) i | (i,ty) <- Map.toList ms]
|
||||
v <- eval [] t args
|
||||
(lins,_) <- value2pmcfg v []
|
||||
return (reverse lins)
|
||||
(lins,params) <- flatten v ty ([],[])
|
||||
lins <- mapM str2lin lins
|
||||
(r,rs,_) <- compute params
|
||||
args <- zipWithM tnk2pmcfgcat args ctxt
|
||||
return (PMCFGRule (PMCFGCat r rs) args (reverse lins))
|
||||
where
|
||||
tnk2pmcfgcat tnk (_,_,ty) = do
|
||||
v <- force tnk []
|
||||
(_,params) <- flatten v ty ([],[])
|
||||
(r,rs,_) <- compute params
|
||||
return (PMCFGCat r rs)
|
||||
|
||||
compute [] = return (0,[],1)
|
||||
compute (v:vs) = do
|
||||
(r, rs ,cnt ) <- param2int v
|
||||
(r',rs',cnt') <- compute vs
|
||||
return (r*cnt'+r',combine cnt' rs rs',cnt*cnt')
|
||||
|
||||
type2metaTerm :: SourceGrammar -> Int -> Map.Map MetaId Type -> LIndex -> [(LIndex,Ident)] -> Type -> (Map.Map MetaId Type,Int,Term)
|
||||
type2metaTerm gr d ms r rs (Sort s) | s == cStr =
|
||||
@@ -71,52 +85,94 @@ type2metaTerm gr d ms r rs ty@(QC q) =
|
||||
let i = Map.size ms + 1
|
||||
in (Map.insert i ty ms,r,Meta i)
|
||||
|
||||
value2pmcfg (VSusp tnk env vs k) lins = do
|
||||
st <- getMeta tnk
|
||||
case st of
|
||||
Unevaluated _ t -> do v <- eval env t vs
|
||||
value2pmcfg v lins
|
||||
|
||||
flatten (VSusp tnk env vs k) ty st = do
|
||||
tnk_st <- getMeta tnk
|
||||
case tnk_st of
|
||||
Evaluated v -> do v <- apply v vs
|
||||
value2pmcfg v lins
|
||||
Unbound (Just (QC q)) _ -> do (m,ps) <- lookupParams q
|
||||
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
|
||||
value2pmcfg v lins
|
||||
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))
|
||||
value2pmcfg (VR as) lins = do
|
||||
(lins,as) <- collectFields lins as
|
||||
return (lins,VR as)
|
||||
flatten (VR as) (RecType lbls) st = do
|
||||
foldM collect st lbls
|
||||
where
|
||||
collectFields lins [] = do
|
||||
return (lins,[])
|
||||
collectFields lins ((lbl,tnk):as) = do
|
||||
collect st (lbl,ty) =
|
||||
case lookup lbl as of
|
||||
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)))
|
||||
flatten v@(VT _ cs) (Table p q) st = do
|
||||
ts <- getAllParamValues p
|
||||
foldM collect st ts
|
||||
where
|
||||
collect st t = do
|
||||
tnk <- newThunk [] t
|
||||
let v0 = VS v tnk []
|
||||
v <- patternMatch v0 (map (\(p,t) -> ([],[p],[tnk],t)) cs)
|
||||
flatten v q st
|
||||
flatten (VV _ tnks) (Table _ q) st = do
|
||||
foldM collect st tnks
|
||||
where
|
||||
collect st tnk = do
|
||||
v <- force tnk []
|
||||
(lins,v) <- value2pmcfg v lins
|
||||
case v of
|
||||
VR [] -> collectFields lins as
|
||||
_ -> do (lins,as) <- collectFields lins as
|
||||
tnk <- newEvaluatedThunk v
|
||||
return (lins,(lbl,tnk):as)
|
||||
value2pmcfg v lins = do
|
||||
lin <- value2lin v
|
||||
return (lin:lins,VR [])
|
||||
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)
|
||||
|
||||
value2lin (VStr s) = return [SymKS s]
|
||||
value2lin (VSymCat d r rs) = do rs <- forM rs $ \(i,tnk) -> do
|
||||
v <- force tnk []
|
||||
j <- case v of
|
||||
VMeta tnk _ _ -> do st <- getMeta tnk
|
||||
case st of
|
||||
Unbound _ j -> return j
|
||||
return (i,j)
|
||||
return [SymCat d r rs]
|
||||
value2lin (VC vs) = fmap concat (mapM value2lin vs)
|
||||
value2lin v = do t <- value2term 0 v
|
||||
evalError ("the term" <+> ppTerm Unqualified 0 t $$
|
||||
"cannot be evaluated at compile time.")
|
||||
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' ) <- compute r' tnks
|
||||
return (r*cnt'+r',combine cnt' rs rs')
|
||||
str2lin (VC vs) = fmap concat (mapM str2lin vs)
|
||||
str2lin v = do t <- value2term 0 v
|
||||
evalError ("the term" <+> ppTerm Unqualified 0 t $$
|
||||
"cannot be evaluated at compile time.")
|
||||
|
||||
param2int (VApp q tnks) = do
|
||||
(r , cnt ) <- getIdxCnt q
|
||||
(r',rs',cnt') <- compute tnks
|
||||
return (r*cnt' + r',rs',cnt*cnt')
|
||||
where
|
||||
getIdxCnt q = do
|
||||
(_,ResValue (L _ ty) idx) <- getInfo q
|
||||
let QC p = valTypeCnc ty
|
||||
(_,ResParam _ (Just (_,cnt))) <- getInfo p
|
||||
return (idx,cnt)
|
||||
|
||||
compute [] = return (0,[],1)
|
||||
compute (tnk:tnks) = do
|
||||
(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
|
||||
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)
|
||||
|
||||
combine cnt' [] rs' = rs'
|
||||
combine cnt' rs [] = [(r*cnt',pv) | (r,pv) <- rs]
|
||||
combine cnt' ((r,pv):rs) ((r',pv'):rs') =
|
||||
case compare pv pv' of
|
||||
LT -> (r*cnt', pv ) : combine cnt' rs ((r',pv'):rs')
|
||||
EQ -> (r*cnt'+r',pv ) : combine cnt' rs ((r',pv'):rs')
|
||||
GT -> ( r',pv') : combine cnt' ((r,pv):rs) rs'
|
||||
|
||||
mapAccumM f a [] = return (a,[])
|
||||
mapAccumM f a (x:xs) = do (a, y) <- f a x
|
||||
|
||||
Reference in New Issue
Block a user