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