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

partial support for runtime parameters

Browse Source
This commit is contained in:
krangelov
2021-10-12 12:06:59 +02:00
parent 5e65db2e17
commit 8c721e063c
6 changed files with 87 additions and 47 deletions
Download Patch File Download Diff File Expand all files Collapse all files

13
src/compiler/GF/Compile/Compute/Concrete.hs
View File

@@ -8,7 +8,7 @@ module GF.Compile.Compute.Concrete
, EvalM, runEvalM, evalError
, eval, apply, force, value2term
, newMeta,getMeta,setMeta
, newEvaluatedThunk,getAllParamValues
, newThunk,newEvaluatedThunk,getAllParamValues
, lookupParams
) where
@@ -34,6 +34,7 @@ import Control.Applicative
import qualified Control.Monad.Fail as Fail
import qualified Data.Map as Map
import GF.Text.Pretty
import PGF2.Transactions(LIndex)
-- * Main entry points
@@ -78,8 +79,9 @@ data Value s
| VPattType (Value s)
| VAlts (Value s) [(Value s, Value s)]
| VStrs [Value s]
| VSymCat Int Int -- This is only generated internally in
-- the PMCFG generator.
-- This last constructor is only generated internally
-- in the PMCFG generator.
| VSymCat Int LIndex [(LIndex, Thunk s)]
eval env (Vr x) vs = case lookup x env of
@@ -181,6 +183,11 @@ eval env (Alts d as) [] = do vd <- eval env d []
return (VAlts vd vas)
eval env (Strs ts) [] = do vs <- mapM (\t -> eval env t []) ts
return (VStrs vs)
eval env (TSymCat d r rs) []= do rs <- forM rs $ \(i,pv) ->
case lookup pv env of
Just tnk -> return (i,tnk)
Nothing -> evalError ("Variable" <+> pp pv <+> "is not in scope")
return (VSymCat d r rs)
eval env t vs = evalError ("Cannot reduce term" <+> pp t)
apply (VMeta m env vs0) vs = do st <- getMeta m

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

@@ -15,13 +15,17 @@ module GF.Compile.GeneratePMCFG
import GF.Grammar hiding (VApp)
import GF.Grammar.Predef
import GF.Grammar.Lookup
import GF.Infra.CheckM
import GF.Infra.Option
import GF.Text.Pretty
import GF.Compile.Compute.Concrete
import GF.Data.Operations(Err(..))
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
@@ -38,35 +42,40 @@ addPMCFG opts cwd gr cmi id_info = return id_info
pmcfgForm :: Grammar -> L Ident -> Term -> Context -> Check [[[Symbol]]]
pmcfgForm gr _ t ctxt =
runEvalM gr $ do
(_,args) <- mapAccumM (\(d,r) (_,_,ty) -> do (r,v) <- type2metaValue d r ty
return ((d+1,r),v))
(0,0) ctxt
((_,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
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)
type2metaValue :: Int -> Int -> Type -> EvalM s (Int,Thunk s)
type2metaValue d r (Sort s) | s == cStr = do
tnk <- newEvaluatedThunk (VSymCat d r)
return (r+1,tnk)
type2metaValue d r (RecType lbls) = do
(r,lbls) <- mapAccumM (\i (lbl,ty) -> do (i,tnk) <- type2metaValue d i ty
return (i,(lbl,tnk)))
r lbls
tnk <- newEvaluatedThunk (VR lbls)
return (r,tnk)
type2metaValue d r (Table p q) = do
ts <- getAllParamValues p
(r,vs) <- mapAccumM (\r _ -> type2metaValue d r q) r ts
tnk <- newEvaluatedThunk (VV p vs)
return (r, tnk)
type2metaValue d r ty@(QC q) = do
tnk <- newMeta (Just ty) 0
return (r, tnk)
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 =
(ms,r+1,TSymCat d r rs)
type2metaTerm gr d ms r rs (RecType lbls) =
let ((ms',r'),ass) = mapAccumL (\(ms,r) (lbl,ty) -> let (ms',r',t) = type2metaTerm gr d ms r rs ty
in ((ms',r'),(lbl,(Just ty,t))))
(ms,r) lbls
in (ms',r',R ass)
type2metaTerm gr d ms r rs (Table p q) =
let pv = identS ('p':show (length rs))
(ms',r',t) = type2metaTerm gr d ms r ((r'-r,pv):rs) q
count = case allParamValues gr p of
Ok ts -> length ts
Bad msg -> error msg
in (ms',(r'-r)*count,T (TTyped p) [(PV pv,t)])
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
Evaluated v -> do v <- apply v vs
value2pmcfg v lins
Unbound (Just (QC q)) _ -> do (m,ps) <- lookupParams q
@@ -92,16 +101,22 @@ value2pmcfg (VR as) lins = do
tnk <- newEvaluatedThunk v
return (lins,(lbl,tnk):as)
value2pmcfg v lins = do
case value2lin v of
Just lin -> return (lin:lins,VR [])
Nothing -> do t <- value2term 0 v
evalError ("the term" <+> ppTerm Unqualified 0 t $$
"cannot be evaluated at compile time.")
lin <- value2lin v
return (lin:lins,VR [])
value2lin (VStr s) = Just [SymKS s]
value2lin (VSymCat d r) = Just [SymCat d r]
value2lin (VC vs) = fmap concat (mapM value2lin vs)
value2lin _ = Nothing
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.")
mapAccumM f a [] = return (a,[])
mapAccumM f a (x:xs) = do (a, y) <- f a x

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

@@ -308,7 +308,7 @@ instance Binary Literal where
_ -> decodingError
instance Binary Symbol where
put (SymCat n l) = putWord8 0 >> put (n,l)
put (SymCat d r rs) = putWord8 0 >> put (d,r,rs)
put (SymLit n l) = putWord8 1 >> put (n,l)
put (SymVar n l) = putWord8 2 >> put (n,l)
put (SymKS ts) = putWord8 3 >> put ts
@@ -321,7 +321,7 @@ instance Binary Symbol where
put SymALL_CAPIT = putWord8 10
get = do tag <- getWord8
case tag of
0 -> liftM2 SymCat get get
0 -> liftM3 SymCat get get get
1 -> liftM2 SymLit get get
2 -> liftM2 SymVar get get
3 -> liftM SymKS get

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

@@ -74,7 +74,7 @@ import GF.Infra.Location
import GF.Data.Operations
import PGF2(BindType(..))
import PGF2.Transactions(Symbol)
import PGF2.Transactions(Symbol,LIndex)
import Data.Array.IArray(Array)
import Data.Array.Unboxed(UArray)
@@ -391,6 +391,7 @@ data Term =
| Alts Term [(Term, Term)] -- ^ alternatives by prefix: @pre {t ; s\/c ; ...}@
| Strs [Term] -- ^ conditioning prefix strings: @strs {s ; ...}@
| TSymCat Int LIndex [(LIndex,Ident)]
deriving (Show, Eq, Ord)
-- | Patterns

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

@@ -234,6 +234,7 @@ ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
ppTerm q d (TSymCat i r rs) = pp '<' <> pp i <> pp ',' <> ppLinFun pp r rs <> pp '>'
ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
@@ -356,16 +357,31 @@ ppLit (PGF2.LStr s) = pp (show s)
ppLit (PGF2.LInt n) = pp n
ppLit (PGF2.LFlt d) = pp d
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 '>'
ppSymbol (PGF2.SymKS t) = doubleQuotes (pp t)
ppSymbol PGF2.SymNE = pp "nonExist"
ppSymbol PGF2.SymBIND = pp "BIND"
ppSymbol PGF2.SymSOFT_BIND = pp "SOFT_BIND"
ppSymbol PGF2.SymSOFT_SPACE= pp "SOFT_SPACE"
ppSymbol PGF2.SymCAPIT = pp "CAPIT"
ppSymbol PGF2.SymALL_CAPIT = pp "ALL_CAPIT"
ppSymbol (PGF2.SymCat d r rs)= pp '<' <> pp d <> pp ',' <> ppLinFun ppIntVar r rs <> 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 '>'
ppSymbol (PGF2.SymKS t) = doubleQuotes (pp t)
ppSymbol PGF2.SymNE = pp "nonExist"
ppSymbol PGF2.SymBIND = pp "BIND"
ppSymbol PGF2.SymSOFT_BIND = pp "SOFT_BIND"
ppSymbol PGF2.SymSOFT_SPACE = pp "SOFT_SPACE"
ppSymbol PGF2.SymCAPIT = pp "CAPIT"
ppSymbol PGF2.SymALL_CAPIT = pp "ALL_CAPIT"
ppSymbol (PGF2.SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts)))
ppLinFun ppParam r rs
| r == 0 && not (null rs) = hcat (intersperse (pp '+') ( map ppTerm rs))
| otherwise = hcat (intersperse (pp '+') (pp r : map ppTerm rs))
where
ppTerm (i,p)
| i == 1 = ppParam p
| otherwise = pp i <> pp '*' <> ppParam p
ppIntVar p
| i == 0 = pp (chars !! j)
| otherwise = pp (chars !! j : show i)
where
chars = "ijklmnopqr"
(i,j) = p `divMod` (length chars)
ppAlt (syms,ps) = hsep (map ppSymbol syms) <+> pp '/' <+> hsep (map (doubleQuotes . pp) ps)

3
src/runtime/haskell/PGF2/Transactions.hsc
View File

@@ -153,8 +153,9 @@ setAbstractFlag name value = Transaction $ \c_db c_revision c_exn ->
type Token = String
type LIndex = Int
type Param = Int
data Symbol
= SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
= SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex [(LIndex,Param)]
| SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
| SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int
| SymKS Token