msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

questions and transfer in shell state

Browse Source
This commit is contained in:
aarne
2005-11-25 17:40:51 +00:00
parent dbe8e61acc
commit fe1fdf3afd
6 changed files with 59 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files

19
src/GF/API.hs
View File

@@ -63,6 +63,8 @@ import GF.UseGrammar.Editing
----import GrammarToMGrammar as M
import qualified Transfer.InterpreterAPI as T
import GF.System.Arch (myStdGen)
import GF.Text.UTF8
@@ -356,6 +358,23 @@ wrapByFun opts gr f t =
t' = qualifTerm (absId gr) $ M.appCons f [tree2exp t]
g = grammar gr
applyTransfer :: Options -> GFGrammar -> [(Ident,T.Env)] ->
(Maybe Ident,Ident) -> Tree -> Tree
applyTransfer opts gr trs (mm,f) t =
err (const t) id $ annotate g t'
where
t' = qualifTerm (absId gr) $ trans tr f $ tree2exp t
g = grammar gr
tr = case mm of
Just m -> maybe empty id $ lookup m trs
_ -> ifNull empty (snd . head) trs
-- these are missing
trans = error "no transfer yet"
----- core2exp . T.appTransfer tr . exp2core
empty = error "emptyEnv"
---- T.emptyEnv
{-
optTransfer :: Options -> StateGrammar -> G.Term -> G.Term
optTransfer opts g = case getOptVal opts transferFun of

5
src/GF/API/IOGrammar.hs
View File

@@ -31,6 +31,8 @@ import GF.Data.Operations
import GF.Infra.UseIO
import GF.System.Arch
import qualified Transfer.InterpreterAPI as T
import Control.Monad (liftM)
-- | a heuristic way of renaming constants is used
@@ -56,6 +58,9 @@ shellStateFromFiles opts st file = do
ign <- ioeIO $ getNoparseFromFile opts file
let top = identC $ justModuleName file
sh <- case fileSuffix file of
"trc" -> do
env <- ioeIO $ T.loadFile file
return $ addTransfer (top,env) st
"gfcm" -> do
cenv <- compileOne opts (compileEnvShSt st []) file
ioeErr $ updateShellState opts ign Nothing st cenv

48
src/GF/Compile/ShellState.hs
View File

@@ -37,6 +37,8 @@ import GF.Infra.Option
import GF.Infra.Ident
import GF.System.Arch (ModTime)
import qualified Transfer.InterpreterAPI as T
import qualified GF.OldParsing.ConvertGrammar as CnvOld -- OBSOLETE
import qualified GF.Conversion.GFC as Cnv
import qualified GF.Parsing.GFC as Prs
@@ -67,7 +69,8 @@ data ShellState = ShSt {
[((G.Fun,Int),G.Type)]))], -- ^ cats, (their contexts,
-- functions to them,
-- functions on them)
statistics :: [Statistics] -- ^ statistics on grammars
statistics :: [Statistics], -- ^ statistics on grammars
transfers :: [(Ident,T.Env)] -- ^ transfer modules
}
actualConcretes :: ShellState -> [((Ident,Ident),Bool)]
@@ -103,7 +106,8 @@ emptyShellState = ShSt {
gloptions = noOptions,
readFiles = [],
absCats = [],
statistics = []
statistics = [],
transfers = []
}
optInitShellState :: Options -> ShellState
@@ -247,7 +251,8 @@ updateShellState opts ign mcnc sh ((_,sgr,gr),rts) = do
gloptions = gloptions sh, --- opts, -- this would be command-line options
readFiles = [ft | ft@(f,_) <- readFiles sh, notInrts f] ++ rts,
absCats = csi,
statistics = [StDepTypes deps,StBoundVars binds]
statistics = [StDepTypes deps,StBoundVars binds],
transfers = transfers sh
}
prShellStateInfo :: ShellState -> String
@@ -259,7 +264,8 @@ prShellStateInfo sh = unlines [
"all concretes : " +++ unwords (map (P.prt . fst . fst) (concretes sh)),
"canonical modules :" +++ unwords (map (P.prt .fst) (M.modules (canModules sh))),
"source modules : " +++ unwords (map (P.prt .fst) (M.modules (srcModules sh))),
"global options : " +++ prOpts (gloptions sh)
"global options : " +++ prOpts (gloptions sh),
"transfer modules : " +++ unwords (map (P.prt . fst) (transfers sh))
]
{- ---- should be called from IOGrammar *before* compiling
@@ -309,7 +315,8 @@ purgeShellState sh = ShSt {
gloptions = gloptions sh,
readFiles = [],
absCats = absCats sh,
statistics = statistics sh
statistics = statistics sh,
transfers = transfers sh
}
where
abstr = abstract sh
@@ -320,17 +327,17 @@ purgeShellState sh = ShSt {
acncs = maybe [] singleton abstr ++ map (snd . fst) (actualConcretes sh)
changeMain :: Maybe Ident -> ShellState -> Err ShellState
changeMain Nothing (ShSt _ _ cs ms ss cfs old_pis mcfgs cfgs pinfos mos pbs os rs acs s) =
return (ShSt Nothing Nothing [] ms ss cfs old_pis mcfgs cfgs pinfos mos pbs os rs acs s)
changeMain Nothing (ShSt _ _ cs ms ss cfs old_pis mcfgs cfgs pinfos mos pbs os rs acs s trs) =
return (ShSt Nothing Nothing [] ms ss cfs old_pis mcfgs cfgs pinfos mos pbs os rs acs s trs)
changeMain
(Just c) st@(ShSt _ _ cs ms ss cfs old_pis mcfgs cfgs pinfos mos pbs os rs acs s) =
(Just c) st@(ShSt _ _ cs ms ss cfs old_pis mcfgs cfgs pinfos mos pbs os rs acs s trs) =
case lookup c (M.modules ms) of
Just _ -> do
a <- M.abstractOfConcrete ms c
let cas = M.allConcretes ms a
let cs' = [((c,c),True) | c <- cas]
return (ShSt (Just a) (Just c) cs' ms ss cfs old_pis mcfgs cfgs
pinfos mos pbs os rs acs s)
pinfos mos pbs os rs acs s trs)
_ -> P.prtBad "The state has no concrete syntax named" c
-- | form just one state grammar, if unique, from a canonical grammar
@@ -482,13 +489,14 @@ stateIsWord :: StateGrammar -> String -> Bool
stateIsWord sg = isKnownWord (stateMorpho sg)
addProbs :: (Ident,Probs) -> ShellState -> Err ShellState
addProbs ip@(lang,probs)
sh@(ShSt x y cs ms ss cfs old_pis mcfgs cfgs pinfos mos pbs os rs acs s) = do
addProbs ip@(lang,probs) sh = do
let gr = grammarOfLang sh lang
probs' <- checkGrammarProbs gr probs
let pbs' = (lang,probs') : filter ((/= lang) . fst) pbs
return (ShSt x y cs ms ss cfs old_pis mcfgs cfgs pinfos mos pbs' os rs acs s)
let pbs' = (lang,probs') : filter ((/= lang) . fst) (probss sh)
return $ sh{probss = pbs'}
addTransfer :: (Ident,T.Env) -> ShellState -> ShellState
addTransfer it sh = sh {transfers = it : transfers sh}
{-
@@ -543,10 +551,8 @@ languageOff = languageOnOff False
languageOnOff :: Bool -> Language -> ShellStateOper
--- __________ this is OBSOLETE
languageOnOff b lang
(ShSt a c cs cg sg cfs old_pinfos mcfgs cfgs pinfos ms pbs os fs cats sts) =
ShSt a c cs' cg sg cfs old_pinfos mcfgs cfgs pinfos ms pbs os fs cats sts where
cs' = [if lang==l then (lc,b) else i | i@(lc@(l,c),_) <- cs]
languageOnOff b lang sh = sh {concretes = cs'} where
cs' = [if lang==l then (lc,b) else i | i@(lc@(l,c),_) <- concretes sh]
{-
updateLanguage :: FilePath -> (Language, StateConcrete) -> ShellStateOper
@@ -564,15 +570,13 @@ removeLanguage lang (ShSt (ab,gs,os)) = ShSt (ab,removeAssoc lang gs, os)
changeOptions :: (Options -> Options) -> ShellStateOper
--- __________ this is OBSOLETE
changeOptions f
(ShSt a c cs can src cfs old_pinfos mcfgs cfgs pinfos ms pbs os ff ts ss) =
ShSt a c cs can src cfs old_pinfos mcfgs cfgs pinfos ms pbs (f os) ff ts ss
changeOptions f sh = sh {gloptions = f (gloptions sh)}
changeModTimes :: [(FilePath,ModTime)] -> ShellStateOper
--- __________ this is OBSOLETE
changeModTimes mfs
(ShSt a c cs can src cfs old_pinfos mcfgs cfgs pinfos ms pbs os ff ts ss) =
ShSt a c cs can src cfs old_pinfos mcfgs cfgs pinfos ms pbs os ff' ts ss
(ShSt a c cs can src cfs old_pinfos mcfgs cfgs pinfos ms pbs os ff ts ss trs) =
ShSt a c cs can src cfs old_pinfos mcfgs cfgs pinfos ms pbs os ff' ts ss trs
where
ff' = mfs ++ [mf | mf@(f,_) <- ff, notElem f (map fst mfs)]

3
src/GF/Shell.hs
View File

@@ -301,6 +301,7 @@ execC co@(comm, opts0) sa@(sh@(st,(h,_,_,_)),a) = checkOptions st co >> case com
CPutTerm -> changeArg (opTT2CommandArg (optTermCommand opts gro) . s2t) sa
CWrapTerm f -> changeArg (opTT2CommandArg (return . wrapByFun opts gro f)) sa
CApplyTransfer f -> changeArg (opTT2CommandArg (return . applyTransfer opts gro transfs f)) sa
CMorphoAnalyse -> changeArg (AString . morphoAnalyse opts gro . prCommandArg) sa
CTestTokenizer -> changeArg (AString . optTokenizer opts gro . prCommandArg) sa
@@ -395,6 +396,8 @@ execC co@(comm, opts0) sa@(sh@(st,(h,_,_,_)),a) = checkOptions st co >> case com
src = srcModules st
cgr = canModules st
transfs = transfers st
s2t a = case a of
ASTrm ('$':c) -> maybe (AError "undefined term") (ATrms . return) $ lookupShTerm sh c
ASTrm s -> err AError (ATrms . return) $ string2treeErr gro s

6
src/GF/Shell/PShell.hs
View File

@@ -119,6 +119,7 @@ pCommand ws = case ws of
"gt" : t -> aTerm CGenerateTrees t
"pt" : s -> aTerm CPutTerm s
"wt" : f : s -> aTerm (CWrapTerm (pzIdent f)) s
"at" : f : s -> aTerm (CApplyTransfer (pmIdent f)) s
"ma" : s -> aString CMorphoAnalyse s
"tt" : s -> aString CTestTokenizer s
"cc" : s -> aUnit $ CComputeConcrete $ unwords s
@@ -175,4 +176,7 @@ pCommand ws = case ws of
aTermLi c ss = (c [], [ASTrm $ unwords ss])
---- (c forms, [ASTrms [term]]) where
---- (forms,term) = ([], s2t (unwords ss)) ---- string2formsAndTerm (unwords ss)
---- (forms,term) = ([], s2t (unwords ss)) ----string2formsAndTerm(unwords ss)
pmIdent m = case span (/='.') m of
(k,_:f) -> (Just (pzIdent k), pzIdent f)
_ -> (Nothing,pzIdent m)

1
src/GF/Shell/ShellCommands.hs
View File

@@ -50,6 +50,7 @@ data Command =
| CGenerateTrees
| CPutTerm
| CWrapTerm I.Ident
| CApplyTransfer (Maybe I.Ident, I.Ident)
| CMorphoAnalyse
| CTestTokenizer
| CComputeConcrete String