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

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

Browse Source
This commit is contained in:
krasimir
2015-02-20 13:26:12 +00:00
parent 8fae104957
commit f848857519
8 changed files with 27 additions and 24 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -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

28
src/compiler/GF/Compile/Compute/ConcreteNew.hs
View File

@@ -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

2
src/compiler/GF/Compile/ConcreteToHaskell.hs
View File

@@ -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

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

@@ -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]

2
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -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

2
src/compiler/GF/Compile/Optimize.hs
View File

@@ -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

3
src/compiler/GF/Infra/Option.hs
View File

@@ -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,

4
src/compiler/GF/Interactive.hs
View File

@@ -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