diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs index 0e8f2b775..1e43c68bd 100644 --- a/src/compiler/GF/Compile/CheckGrammar.hs +++ b/src/compiler/GF/Compile/CheckGrammar.hs @@ -224,7 +224,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ 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 (CN.resourceValues gr) (L loct c) . fst -- !! + then CN.checkLType gr ty typeType >>= return . CN.normalForm (CN.resourceValues opts gr) (L loct c) . 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 01e713f01..ee4c8ab80 100644 --- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs +++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs @@ -15,6 +15,7 @@ import GF.Compile.Compute.Predef(predef,predefName,delta) import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok) import GF.Data.Operations(Err,err,errIn,maybeErr,combinations,mapPairsM) import GF.Data.Utilities(mapFst,mapSnd,mapBoth) +import GF.Infra.Option import Control.Monad(ap,liftM,liftM2,unless) --,mplus import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf --import Data.Char (isUpper,toUpper,toLower) @@ -25,9 +26,9 @@ import qualified Data.Map as Map -- * Main entry points normalForm :: GlobalEnv -> L Ident -> Term -> Term -normalForm (GE gr rv _) loc = err (bugloc loc) id . nfx (GE gr rv loc) +normalForm (GE gr rv opts _) loc = err (bugloc loc) id . nfx (GE gr rv opts loc) -nfx env@(GE _ _ loc) t = value2term loc [] # eval env t +nfx env@(GE _ _ _ loc) t = value2term loc [] # eval env t eval :: GlobalEnv -> Term -> Err Value eval ge t = ($[]) # value (toplevel ge) t @@ -40,8 +41,9 @@ apply env = apply' env type ResourceValues = Map.Map ModuleName (Map.Map Ident (Err Value)) -data GlobalEnv = GE Grammar ResourceValues (L Ident) +data GlobalEnv = GE Grammar ResourceValues Options (L Ident) data CompleteEnv = CE {srcgr::Grammar,rvs::ResourceValues, + opts::Options, gloc::L Ident,local::LocalScope} type LocalScope = [Ident] type Stack = [Value] @@ -49,8 +51,8 @@ type OpenValue = Stack->Value ext b env = env{local=b:local env} extend bs env = env{local=bs++local env} -global env = GE (srcgr env) (rvs env) (gloc env) -toplevel (GE gr rvs loc) = CE gr rvs loc [] +global env = GE (srcgr env) (rvs env) (opts env) (gloc env) +toplevel (GE gr rvs opts loc) = CE gr rvs opts loc [] var :: CompleteEnv -> Ident -> Err OpenValue var env x = maybe unbound pick' (elemIndex x (local env)) @@ -76,14 +78,14 @@ resource env (m,c) = where e = fail $ "Not found: "++render m++"."++showIdent c -- | Convert operators once, not every time they are looked up -resourceValues :: SourceGrammar -> GlobalEnv -resourceValues gr = env +resourceValues :: Options -> SourceGrammar -> GlobalEnv +resourceValues opts gr = env where - env = GE gr rvs (L NoLoc identW) + env = GE gr rvs opts (L NoLoc identW) rvs = Map.mapWithKey moduleResources (moduleMap gr) moduleResources m = Map.mapWithKey (moduleResource m) . jments moduleResource m c _info = do L l t <- lookupResDefLoc gr (m,c) - eval (GE gr rvs (L l c)) t + eval (GE gr rvs opts (L l c)) t -- * Computing values @@ -254,9 +256,11 @@ glue env (v1,v2) = glu v1 v2 (v1@(VApp NonExist _),_) -> v1 (_,v2@(VApp NonExist _)) -> v2 -- (v1,v2) -> ok2 VGlue v1 v2 - (v1,v2) -> error . render $ - ppL loc (hang "unsupported token gluing:" 4 - (Glue (vt v1) (vt v2))) + (v1,v2) -> if flag optPlusAsBind (opts env) + then VC v1 (VC (VApp BIND []) v2) + else error . render $ + ppL loc (hang "unsupported token gluing:" 4 + (Glue (vt v1) (vt v2))) vt = value2term loc (local env) loc = gloc env diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs index f25246bd3..a2106a2f4 100644 --- a/src/compiler/GF/Compile/ConcreteToHaskell.hs +++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs @@ -20,7 +20,7 @@ import Debug.Trace concretes2haskell opts absname gr = [(cncname,concrete2haskell opts gr cenv absname cnc cncmod) - | let cenv = resourceValues gr, + | let cenv = resourceValues opts gr, cnc<-allConcretes gr absname, let cncname = render cnc ++ ".hs" Ok cncmod = lookupModule gr cnc diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index 0dfcfcc09..df040793a 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -25,7 +25,7 @@ import GF.Data.BacktrackM import GF.Data.Operations import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE, import GF.Data.Utilities (updateNthM) --updateNth -import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues) +import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.List as List @@ -51,7 +51,7 @@ generatePMCFG opts sgr opath cmo@(cm,cmi) = do when (verbAtLeast opts Verbose) $ ePutStrLn "" return (cm,cmi{mseqs = Just (mkSetArray seqs), jments = js}) where - cenv = resourceValues gr + cenv = resourceValues opts gr gr = prependModule sgr cmo MTConcrete am = mtype cmi @@ -161,9 +161,7 @@ convert opts gr cenv loc term ty@(_,val) pargs = conv t = convertTerm opts CNil val =<< unfactor t eterm = expand ty term - term' = {-if flag optNewComp opts - then-} normalForm cenv loc eterm -- new evaluator - --else term -- old evaluator is invoked from GF.Compile.Optimize + term' = normalForm cenv loc eterm expand (context,val) = mkAbs pars . recordExpand val . flip mkApp args where pars = [(Explicit,v) | v <- vars] diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index 989b651bb..39202de4c 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/src/compiler/GF/Compile/GrammarToPGF.hs @@ -36,7 +36,7 @@ mkCanon2pgf opts gr am = do cncs <- mapM mkConcr (allConcretes gr am) return $ updateProductionIndices (D.PGF Map.empty an abs (Map.fromList cncs)) where - cenv = resourceValues gr + cenv = resourceValues opts gr mkAbstr am = return (mi2i am, D.Abstr flags funs cats) where diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs index 0d45825f1..28d0a7acb 100644 --- a/src/compiler/GF/Compile/Optimize.hs +++ b/src/compiler/GF/Compile/Optimize.hs @@ -50,7 +50,7 @@ optimizeModule opts sgr m@(name,mi) where oopts = opts `addOptions` mflags mi - resenv = resourceValues sgr + resenv = resourceValues oopts sgr updateEvalInfo mi (i,info) = do info <- evalInfo oopts resenv sgr (name,mi) i info diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 885571276..6070e9a38 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -173,6 +173,7 @@ data Flags = Flags { optDump :: [Dump], optTagsOnly :: Bool, optHeuristicFactor :: Maybe Double, + optPlusAsBind :: Bool, optJobs :: Maybe (Maybe Int) } deriving (Show) @@ -281,6 +282,7 @@ defaultFlags = Flags { optDump = [], optTagsOnly = False, optHeuristicFactor = Nothing, + optPlusAsBind = False, optJobs = Nothing } @@ -363,6 +365,7 @@ optDescr = Option [] ["cse"] (onOff (toggleOptimize OptCSE) True) "Perform common sub-expression elimination (default on).", Option [] ["cfg"] (ReqArg cfgTransform "TRANS") "Enable or disable specific CFG transformations. TRANS = merge, no-merge, bottomup, no-bottomup, ...", Option [] ["heuristic_search_factor"] (ReqArg (readDouble (\d o -> o { optHeuristicFactor = Just d })) "FACTOR") "Set the heuristic search factor for statistical parsing", + Option [] ["plus-as-bind"] (NoArg (set $ \o -> o{optPlusAsBind=True})) "Uses of (+) with runtime variables automatically generate BIND (experimental feature).", dumpOption "source" Source, dumpOption "rebuild" Rebuild, dumpOption "extend" Extend, diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 16495d9dd..82806bebb 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -333,9 +333,7 @@ checkComputeTerm sgr t = do mo <- maybe (raise "no source grammar in scope") return $ greatestResource sgr ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t inferLType sgr [] t - t1 <- {-if new - then-} return (CN.normalForm (CN.resourceValues sgr) (L NoLoc identW) t) - {-else computeConcrete sgr t-} + t1 <- return (CN.normalForm (CN.resourceValues noOptions sgr) (L NoLoc identW) t) checkPredefError t1 fetchCommand :: GFEnv -> IO String