added option -plus-as-bind which treats (+) as a bind when used with runtime variables

8 files changed, 27 insertions, 24 deletions

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