summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/compiler/GF/Compile/CheckGrammar.hs2
-rw-r--r--src/compiler/GF/Compile/Compute/ConcreteNew.hs111
-rw-r--r--src/compiler/GF/Compile/Compute/Predef.hs7
-rw-r--r--src/compiler/GF/Compile/Compute/Value.hs2
-rw-r--r--src/compiler/GF/Compile/GeneratePMCFG.hs29
-rw-r--r--src/compiler/GF/Compile/GrammarToPGF.hs12
-rw-r--r--src/compiler/GF/Grammar/Grammar.hs2
-rw-r--r--src/compiler/GFI.hs4
8 files changed, 102 insertions, 67 deletions
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index 50af38add..c628b7c83 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -218,7 +218,7 @@ checkInfo opts sgr (m,mo) c info = do
(Just (L loct ty), Just (L locd de)) -> do
ty' <- chIn loct "operation" $
(if False --flag optNewComp opts
- then CN.checkLType gr ty typeType >>= return . CN.normalForm gr . fst
+ then CN.checkLType gr ty typeType >>= return . CN.normalForm (CN.resourceValues gr) . fst -- !!
else checkLType gr [] ty typeType >>= computeLType gr [] . fst)
(de',_) <- chIn locd "operation" $
(if False -- flag optNewComp opts
diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs
index 0519a84bd..66dc4b7c8 100644
--- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs
@@ -2,6 +2,7 @@
-- | preparation for PMCFG generation.
module GF.Compile.Compute.ConcreteNew
( normalForm
+ , GlobalEnv, resourceValues
, Value(..), Env, eval, apply, value2term
) where
@@ -9,7 +10,7 @@ import GF.Grammar hiding (Env, VGen, VApp, VRecType)
import GF.Grammar.Lookup(lookupResDef,allParamValues)
import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr)
import GF.Grammar.PatternMatch(matchPattern)
-import GF.Grammar.Lockfield(unlockRecord,lockLabel,isLockLabel)
+import GF.Grammar.Lockfield(unlockRecord,lockLabel,isLockLabel,lockRecType)
import GF.Compile.Compute.Value
import GF.Compile.Compute.Predef(predefs)
import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok)
@@ -25,30 +26,52 @@ import Debug.Trace(trace)
-- * Main entry points
-normalForm :: SourceGrammar -> Term -> Term
-normalForm gr = nfx gr []
-nfx gr env = value2term gr [] . eval gr env
+normalForm :: GlobalEnv -> Term -> Term
+normalForm = nfx . toplevel
+nfx env = value2term (srcgr env) [] . value env
-eval :: SourceGrammar -> Env -> Term -> Value
-eval gr env t = value (gr,env) t
+eval :: GlobalEnv -> Term -> Value
+eval = value . toplevel
-apply gr env = apply' (gr,env)
+apply env = apply' env
--------------------------------------------------------------------------------
-- * Environments
-type CompleteEnv = (SourceGrammar,Env)
+type ResourceValues = Map.Map Ident (Map.Map Ident (Err Value))
-ext b (gr,env) = (gr,b:env)
+data GlobalEnv = GE SourceGrammar ResourceValues
+data CompleteEnv = CE {srcgr::SourceGrammar,rvs::ResourceValues,local::Env}
-var env x = maybe unbound id (lookup x (snd env))
+ext b env = env{local=b:local env}
+extend bs env = env{local=bs++local env}
+global env = GE (srcgr env) (rvs env)
+toplevel (GE gr rvs) = CE gr rvs []
+
+var env x = maybe unbound id (lookup x (local env))
where unbound = bug ("Unknown variable: "++showIdent x)
+resource env (m,c) =
+ err bug id $
+ if isPredefCat c
+ then fmap (value0 env) (lockRecType c defLinType) -- hmm
+ else maybe e id $ Map.lookup c =<< Map.lookup m (rvs env)
+ where e = fail $ "Not found: "++showIdent m++"."++showIdent c
+
+-- | Convert operators once, not every time they are looked up
+resourceValues :: SourceGrammar -> GlobalEnv
+resourceValues gr = env
+ where
+ env = GE gr rvs
+ rvs = Map.mapWithKey moduleResources (moduleMap gr)
+ moduleResources m = Map.mapWithKey (moduleResource m) . jments
+ moduleResource m c _info = fmap (eval env) (lookupResDef gr (m,c))
+
-- * Computing values
-- | Computing the value of a top-level term
-value0 gr t = eval gr [] t
+value0 = eval . global
-- | Computing the value of a term
value :: CompleteEnv -> Term -> Value
@@ -58,13 +81,13 @@ value env t0 =
Q x@(m,f)
| m == cPredef -> if f==cErrorType -- to be removed
then let p = identC (BS.pack "P")
- in value0 (fst env) (mkProd [(Implicit,p,typeType)] (Vr p) [])
+ in value0 env (mkProd [(Implicit,p,typeType)] (Vr p) [])
else VApp x []
- | otherwise -> valueResDef (fst env) x
+ | otherwise -> resource env x --valueResDef (fst env) x
QC x -> VCApp x []
App e1 e2 -> apply' env e1 [value env e2]
Let (x,(oty,t)) body -> value (ext (x,value env t) env) body
- Meta i -> VMeta i (snd env) []
+ Meta i -> VMeta i (local env) []
Prod bt x t1 t2 -> VProd bt (value env t1) x (Bind $ \ vx -> value (ext (x,vx) env) t2)
Abs bt x t -> VAbs bt x (Bind $ \ vx -> value (ext (x,vx) env) t)
EInt n -> VInt n
@@ -80,9 +103,9 @@ value env t0 =
FV ts -> vfv (map (value env) ts)
R as -> VRec [(lbl,value env t)|(lbl,(oty,t))<-as]
T i cs -> valueTable env i cs
- V ty ts -> VV ty (map (value env) ts)
+ V ty ts -> VV ty (paramValues env ty) (map (value env) ts)
C t1 t2 -> vconcat (both (value env) (t1,t2))
- S t1 t2 -> select (fst env) (both (value env) (t1,t2))
+ S t1 t2 -> select env (both (value env) (t1,t2))
P t l -> --maybe (bug $ "project "++show l++" from "++show v) id $
maybe (VP v l) id $
proj l v where v = (value env t)
@@ -93,7 +116,11 @@ value env t0 =
EPatt p -> VPatt p -- hmm
t -> ppbug (text "value"<+>ppTerm Unqualified 10 t $$ text (show t))
-valueResDef gr = err bug (value0 gr) . lookupResDef gr
+--valueResDef gr = err bug (value0 gr) . lookupResDef gr
+
+paramValues env ty = let pty = nfx env ty
+ ats = err bug id $ allParamValues (srcgr env) pty
+ in map (value0 env) ats
vconcat vv@(v1,v2) =
case vv of
@@ -145,7 +172,7 @@ extR t vv =
ls -> error $ text "clash"<+>text (show ls)
(VRec rs1, VRec rs2) -> plusVRec rs1 rs2
(v1 , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm
- (VS (VV t vs) s,v2) -> VS (VV t [extR t (v1,v2)|v1<-vs]) s
+ (VS (VV t pvs vs) s,v2) -> VS (VV t pvs [extR t (v1,v2)|v1<-vs]) s
(v1,v2) -> ok2 VExtR v1 v2 -- hmm
-- (v1,v2) -> error $ text "not records" $$ text (show v1) $$ text (show v2)
where
@@ -166,8 +193,8 @@ glue vv = case vv of
return $ vfv [foldr1 VC (map VString (str2strings (glueStr v u))) | v <- x', u <- y']
(VC va vb,v2) -> VC va (glue (vb,v2))
(v1,VC va vb) -> VC (glue (va,va)) vb
- (VS (VV ty vs) vb,v2) -> VS (VV ty [glue (v,v2)|v<-vs]) vb
- (v1,VS (VV ty vs) vb) -> VS (VV ty [glue (v1,v)|v<-vs]) vb
+ (VS (VV ty pvs vs) vb,v2) -> VS (VV ty pvs [glue (v,v2)|v<-vs]) vb
+ (v1,VS (VV ty pvs vs) vb) -> VS (VV ty pvs [glue (v1,v)|v<-vs]) vb
-- (v1,v2) -> ok2 VGlue v1 v2
(v1,v2) -> bug vv
where
@@ -205,43 +232,44 @@ vfv vs = case nub vs of
[v] -> v
vs -> VFV vs
-select gr vv =
+select env vv =
case vv of
- (v1,VFV vs) -> vfv [select gr (v1,v2)|v2<-vs]
- (VFV vs,v2) -> vfv [select gr (v1,v2)|v1<-vs]
- (v1@(VV pty rs),v2) ->
+ (v1,VFV vs) -> vfv [select env (v1,v2)|v2<-vs]
+ (VFV vs,v2) -> vfv [select env (v1,v2)|v1<-vs]
+ (v1@(VV pty vs rs),v2) ->
err (const (VS v1 v2)) id $
- do ats <- allParamValues gr pty
- let vs = map (value0 gr) ats
+ do --ats <- allParamValues (srcgr env) pty
+ --let vs = map (value0 env) ats
i <- maybeErr "no match" $ findIndex (==v2) vs
return (rs!!i)
(v1@(VT i cs),v2) ->
- err bug (valueMatch gr) $ matchPattern cs (value2term gr [] v2)
- (VS (VV pty rs) v12,v2) -> VS (VV pty [select gr (v11,v2)|v11<-rs]) v12
+ err bug (valueMatch env) $ matchPattern cs (value2term (srcgr env) [] v2)
+ (VS (VV pty pvs rs) v12,v2) -> VS (VV pty pvs [select env (v11,v2)|v11<-rs]) v12
(v1,v2) -> ok2 VS v1 v2
-valueMatch gr (Bind f,env') = f (mapSnd (value0 gr) env')
+valueMatch env (Bind f,env') = f (mapSnd (value0 env) env')
-valueTable env@(gr,bs) i cs =
+valueTable env i cs =
case i of
- TComp ty -> VV ty (map (value env.snd) cs)
+ TComp ty -> VV ty (paramValues env ty) (map (value env.snd) cs)
_ -> err keep id convert
where
keep _ = VT i (err bug id $ mapM valueCase cs)
valueCase (p,t) = do p' <- inlinePattMacro p
- return (p',Bind $ \ bs' -> value (gr,bs'++bs) t)
-
+ return (p',Bind $ \ bs' -> value (extend bs' env) t)
+--{-
convert = do ty <- getTableType i
- let pty = nfx gr bs ty
- vs <- allParamValues gr pty
+ let pty = nfx env ty
+ vs <- allParamValues (srcgr env) pty
+ let pvs = map (value0 env) vs
cs' <- mapM valueCase cs
sts <- mapM (matchPattern cs') vs
- return $ VV pty (map (valueMatch gr) sts)
-
+ return $ VV pty pvs (map (valueMatch env) sts)
+--}
inlinePattMacro p =
case p of
- PM qc -> case valueResDef gr qc of
+ PM qc -> case resource env qc of
VPatt p' -> inlinePattMacro p'
r -> ppbug $ hang (text "Expected pattern macro:") 4
(text (show r))
@@ -254,8 +282,7 @@ apply' env t vs =
Q x@(m,f) | m==cPredef -> let constr = --trace ("predef "++show x) .
VApp x
in maybe constr id (Map.lookup f predefs) vs
- | otherwise -> err bug (\t->apply' (fst env,[]) t vs)
- (lookupResDef (fst env) x)
+ | otherwise -> vapply (resource env x) vs
App t1 t2 -> apply' env t1 (value env t2 : vs)
-- Abs b x t -> beta env b x t vs
_ -> vapply (value env t) vs
@@ -266,7 +293,7 @@ vapply v vs =
VError {} -> v
-- VClosure env (Abs b x t) -> beta gr env b x t vs
VAbs bt _ (Bind f) -> vbeta bt f vs
- VS (VV t fs) s -> VS (VV t [vapply f vs|f<-fs]) s
+ VS (VV t pvs fs) s -> VS (VV t pvs [vapply f vs|f<-fs]) s
VFV fs -> vfv [vapply f vs|f<-fs]
v -> bug $ "vapply "++show v++" "++show vs
@@ -308,7 +335,7 @@ value2term gr xs v0 =
VTblType p res -> Table (v2t p) (v2t res)
VRecType rs -> RecType [(l,v2t v) | (l,v) <- rs]
VRec as -> R [(l,(Nothing,v2t v))|(l,v) <- as]
- VV t vs -> V t (map v2t vs)
+ VV t _ vs -> V t (map v2t vs)
VT i cs -> T i (map nfcase cs)
VFV vs -> FV (map v2t vs)
VC v1 v2 -> C (v2t v1) (v2t v2)
diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs
index 1647b2a92..e6fd6af7c 100644
--- a/src/compiler/GF/Compile/Compute/Predef.hs
+++ b/src/compiler/GF/Compile/Compute/Predef.hs
@@ -9,8 +9,9 @@ import Data.Char (isUpper,toLower,toUpper)
import GF.Data.Utilities (mapSnd,apBoth)
import GF.Compile.Compute.Value
-import GF.Infra.Ident (Ident)
+import GF.Infra.Ident (Ident,varX)
import GF.Grammar.Predef
+import PGF.Data(BindType(..))
predefs :: Map.Map Ident ([Value]->Value)
predefs = Map.fromList $ mapSnd strictf
@@ -40,6 +41,10 @@ predefs = Map.fromList $ mapSnd strictf
apISS f vs = case vs of
[VInt i, VString s] -> string (f i s)
+ [VInt i] -> VAbs Explicit (varX 0) $ Bind $ \ v ->
+ case norm v of
+ VString s -> string (f i s)
+ _ -> bug $ "f::Int->Str->Str got "++show (vs++[v])
_ -> bug $ "f::Int->Str->Str got "++show vs
apSSB f vs = case vs of
diff --git a/src/compiler/GF/Compile/Compute/Value.hs b/src/compiler/GF/Compile/Compute/Value.hs
index c47c67acb..07d79ca26 100644
--- a/src/compiler/GF/Compile/Compute/Value.hs
+++ b/src/compiler/GF/Compile/Compute/Value.hs
@@ -21,7 +21,7 @@ data Value
| VTblType Value Value
| VRecType [(Label,Value)]
| VRec [(Label,Value)]
- | VV Type [Value]
+ | VV Type [Value] [Value] -- preserve type for conversion back to Term
| VT TInfo [(Patt,Bind Env)]
| VC Value Value
| VS Value Value
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index feb26c38f..bae883da5 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -10,7 +10,7 @@
-----------------------------------------------------------------------------
module GF.Compile.GeneratePMCFG
- (generatePMCFG, pgfCncCat, addPMCFG
+ (generatePMCFG, pgfCncCat, addPMCFG, resourceValues
) where
import PGF.CId
@@ -23,7 +23,7 @@ import GF.Grammar.Predef
import GF.Data.BacktrackM
import GF.Data.Operations
import GF.Data.Utilities (updateNthM, updateNth)
-import GF.Compile.Compute.ConcreteNew(normalForm)
+import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
import System.IO(hPutStr,hPutStrLn,stderr)
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -45,10 +45,11 @@ import Control.Exception
generatePMCFG :: Options -> SourceGrammar -> SourceModule -> IO SourceModule
generatePMCFG opts sgr cmo@(cm,cmi) = do
- (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr am cm) Map.empty (jments cmi)
+ (seqs,js) <- mapAccumWithKeyM (addPMCFG opts gr cenv am cm) Map.empty (jments cmi)
when (verbAtLeast opts Verbose) $ hPutStrLn stderr ""
return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js})
where
+ cenv = resourceValues gr
gr = prependModule sgr cmo
MTConcrete am = mtype cmi
@@ -64,14 +65,14 @@ mapAccumWithKeyM f a m = do let xs = Map.toAscList m
return (a,(k,y):kys)
-addPMCFG :: Options -> SourceGrammar -> Ident -> Ident -> SeqSet -> Ident -> Info -> IO (SeqSet, Info)
-addPMCFG opts gr am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L _ term)) mprn Nothing) = do
+addPMCFG :: Options -> SourceGrammar -> GlobalEnv -> Ident -> Ident -> SeqSet -> Ident -> Info -> IO (SeqSet, Info)
+addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin@(Just (L _ term)) mprn Nothing) = do
let pres = protoFCat gr res val
pargs = [protoFCat gr (snd $ catSkeleton ty) lincat | ((_,_,ty),(_,_,lincat)) <- zip ctxt cont]
pmcfgEnv0 = emptyPMCFGEnv
- b = convert opts gr term val pargs
+ b = convert opts gr cenv term val pargs
(seqs1,b1) = addSequencesB seqs b
pmcfgEnv1 = foldBM addRule
pmcfgEnv0
@@ -98,13 +99,13 @@ addPMCFG opts gr am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont,val)) mlin
newArgs = map getFIds newArgs'
in addFunction env0 newCat fun newArgs
-addPMCFG opts gr am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L _ term)) mprn Nothing) = do
+addPMCFG opts gr cenv am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(Just (L _ term)) mprn Nothing) = do
let pres = protoFCat gr (am,id) lincat
parg = protoFCat gr (identW,cVar) typeStr
pmcfgEnv0 = emptyPMCFGEnv
- b = convert opts gr term lincat [parg]
+ b = convert opts gr cenv term lincat [parg]
(seqs1,b1) = addSequencesB seqs b
pmcfgEnv1 = foldBM addRule
pmcfgEnv0
@@ -119,14 +120,14 @@ addPMCFG opts gr am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) mdef@(
!fun = mkArray lins
in addFunction env0 newCat fun [[fidVar]]
-addPMCFG opts gr am cm seqs id info = return (seqs, info)
+addPMCFG opts gr cenv am cm seqs id info = return (seqs, info)
-convert opts gr term val pargs =
+convert opts gr cenv term val pargs =
runCnvMonad gr conv (pargs,[])
where
- conv = convertTerm opts CNil val =<< unfactor term'
+ conv = convertTerm opts CNil val =<< unfactor cenv term'
term' = if flag optNewComp opts
- then normalForm gr (recordExpand val term) -- new evaluator
+ then normalForm cenv (recordExpand val term) -- new evaluator
else term -- old evaluator is invoked from GF.Compile.Optimize
recordExpand :: Type -> Term -> Term
@@ -142,8 +143,8 @@ recordExpand typ trm =
_ -> R [assign lab (P trm lab) | (lab,_) <- tys]
_ -> trm
-unfactor :: Term -> CnvMonad Term
-unfactor t = CM (\gr c -> c (unfac gr t))
+unfactor :: GlobalEnv -> Term -> CnvMonad Term
+unfactor cenv t = CM (\gr c -> c (unfac gr t))
where
unfac gr t =
case t of
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index 5515a8876..f9b008bf8 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -38,11 +38,13 @@ import Control.Monad.Identity
mkCanon2pgf :: Options -> SourceGrammar -> Ident -> IO D.PGF
mkCanon2pgf opts gr am = do
- (an,abs) <- mkAbstr gr am
- cncs <- mapM (mkConcr gr) (allConcretes gr am)
+ (an,abs) <- mkAbstr am
+ cncs <- mapM mkConcr (allConcretes gr am)
return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs))
where
- mkAbstr gr am = return (i2i am, D.Abstr flags funs cats bcode)
+ cenv = resourceValues gr
+
+ mkAbstr am = return (i2i am, D.Abstr flags funs cats bcode)
where
aflags =
concatOptions (reverse [mflags mo | (_,mo) <- modules gr, isModAbs mo])
@@ -64,7 +66,7 @@ mkCanon2pgf opts gr am = do
(map (\x -> (0,snd x)) . sortBy (compare `on` fst))
[(loc,i2i f) | ((m,f),AbsFun (Just (L loc ty)) _ _ (Just True),_) <- adefs, snd (GM.valCat ty) == cat]
- mkConcr gr cm = do
+ mkConcr cm = do
let cflags = concatOptions [mflags mo | (i,mo) <- modules gr, isModCnc mo,
Just r <- [lookup i (allExtendSpecs gr cm)]]
@@ -96,7 +98,7 @@ mkCanon2pgf opts gr am = do
-- we have to create the PMCFG code just before linking
addMissingPMCFGs seqs [] = return (seqs,[])
addMissingPMCFGs seqs (((m,id), info):is) = do
- (seqs,info) <- addPMCFG opts gr am cm seqs id info
+ (seqs,info) <- addPMCFG opts gr cenv am cm seqs id info
(seqs,is ) <- addMissingPMCFGs seqs is
return (seqs, ((m,id), info) : is)
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index 01d9cc9ec..3a6d4c25f 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -16,7 +16,7 @@
module GF.Grammar.Grammar (
SourceGrammar, SourceModInfo(..), SourceModule, ModuleType(..),
- emptySourceGrammar, mGrammar, modules, prependModule,
+ emptySourceGrammar, mGrammar, modules, prependModule, moduleMap,
MInclude (..), OpenSpec(..),
extends, isInherited, inheritAll,
diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs
index 980264042..55256c3d7 100644
--- a/src/compiler/GFI.hs
+++ b/src/compiler/GFI.hs
@@ -18,7 +18,7 @@ import GF.Grammar.ShowTerm
import GF.Grammar.Lookup (allOpers,allOpersTo)
import GF.Compile.Rename(renameSourceTerm)
import GF.Compile.Compute.Concrete (computeConcrete,checkPredefError)
-import qualified GF.Compile.Compute.ConcreteNew as CN(normalForm)
+import qualified GF.Compile.Compute.ConcreteNew as CN(normalForm,resourceValues)
import GF.Compile.TypeCheck.Concrete (inferLType,ppType)
import GF.Infra.Dependencies(depGraph)
import GF.Infra.CheckM
@@ -333,7 +333,7 @@ checkComputeTerm' new sgr t = do
((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
inferLType sgr [] t
t1 <- if new
- then return (CN.normalForm sgr t)
+ then return (CN.normalForm (CN.resourceValues sgr) t)
else computeConcrete sgr t
checkPredefError sgr t1