diff --git a/lib/resource-1.0/gf/Cat.gf b/lib/resource-1.0/gf/Cat.gf index a5f283b12..b74198ad5 100644 --- a/lib/resource-1.0/gf/Cat.gf +++ b/lib/resource-1.0/gf/Cat.gf @@ -1,15 +1,13 @@ abstract Cat = { cat S ; - Cl ; QS ; + + Cl ; QCl ; Slash ; - VP ; - AP ; - Comp ; V ; V2 ; @@ -18,6 +16,9 @@ abstract Cat = { VS ; VQ ; + AP ; + Comp ; + Adv ; CN ; @@ -33,4 +34,12 @@ abstract Cat = { Quant ; Num ; + Prep ; + + IP ; + IAdv ; + IDet ; + + RP ; + } \ No newline at end of file diff --git a/lib/resource-1.0/gf/CatEng.gf b/lib/resource-1.0/gf/CatEng.gf index 3715e7504..a63134af5 100644 --- a/lib/resource-1.0/gf/CatEng.gf +++ b/lib/resource-1.0/gf/CatEng.gf @@ -1,22 +1,26 @@ concrete CatEng of Cat = open ResEng in { lincat - S = {s : Str} ; + S = {s : Str} ; + QS = {s : QForm => Str} ; + Cl = {s : Tense => Anteriority => Polarity => Ord => Str} ; Slash = {s : Tense => Anteriority => Polarity => Ord => Str} ** {c2 : Str} ; + QCl = {s : Tense => Anteriority => Polarity => QForm => Str} ; + VP = { s : Tense => Anteriority => Polarity => Ord => Agr => {fin, inf : Str} ; s2 : Agr => Str } ; - AP = {s : Str} ; - Comp = {s : Agr => Str} ; - V, VS, VQ = Verb ; -- = {s : VForm => Str} ; V2, VV = Verb ** {c2 : Str} ; V3 = Verb ** {c2, c3 : Str} ; + AP = {s : Str} ; + Comp = {s : Agr => Str} ; + Adv = {s : Str} ; Det, Quant = {s : Str ; n : Number} ; @@ -28,4 +32,8 @@ concrete CatEng of Cat = open ResEng in { N2 = {s : Number => Case => Str} ** {c2 : Str} ; N3 = {s : Number => Case => Str} ** {c2,c3 : Str} ; + IP = {s : Case => Str ; n : Number} ; + IDet = {s : Str ; n : Number} ; + IAdv = {s : Str} ; + } diff --git a/lib/resource-1.0/gf/Lex.gf b/lib/resource-1.0/gf/Lex.gf index 6fcd22c04..5e3b6bdb0 100644 --- a/lib/resource-1.0/gf/Lex.gf +++ b/lib/resource-1.0/gf/Lex.gf @@ -1,4 +1,5 @@ abstract Lex = Cat ** { + fun walk_V : V ; kill_V2 : V2 ; @@ -11,8 +12,22 @@ abstract Lex = Cat ** { dog_N : N ; son_N2 : N2 ; way_N3 : N3 ; + +-- structural + + + only_Predet : Predet ; + + this_Quant : Quant ; + i_Pron, he_Pron, we_Pron : Pron ; + whoSg_IP, whoPl_IP, whatSg_IP, whatPl_IP : IP ; + + when_IAdv, where_IAdv, why_IAdv : IAdv ; + + whichSg_IDet, whichPl_IDet : IDet ; + here_Adv : Adv ; } diff --git a/lib/resource-1.0/gf/LexEng.gf b/lib/resource-1.0/gf/LexEng.gf index a2a29beee..434f6162d 100644 --- a/lib/resource-1.0/gf/LexEng.gf +++ b/lib/resource-1.0/gf/LexEng.gf @@ -14,11 +14,14 @@ concrete LexEng of Lex = CatEng ** open ResEng in { here_Adv = {s = "here"} ; --- structural + only_Predet = {s = "only"} ; + this_Quant = {s = "this" ; n = Sg} ; i_Pron = mkNP "I" "me" "my" Sg P1 ; he_Pron = mkNP "he" "him" "his" Sg P3 ; we_Pron = mkNP "we" "us" "our" Pl P1 ; + whoSg_IP = mkIP "who" "whom" "whose" Sg ; + whoPl_IP = mkIP "who" "whom" "whose" Pl ; } diff --git a/lib/resource-1.0/gf/Noun.gf b/lib/resource-1.0/gf/Noun.gf index e99bd1154..6c3dca9f8 100644 --- a/lib/resource-1.0/gf/Noun.gf +++ b/lib/resource-1.0/gf/Noun.gf @@ -4,7 +4,6 @@ abstract Noun = Cat ** { DetCN : Det -> CN -> NP ; UsePN : PN -> NP ; UsePron : Pron -> NP ; - UsePron2 : Pron -> NP ; MkDet : Predet -> Quant -> Num -> Det ; @@ -31,9 +30,4 @@ abstract Noun = Cat ** { UseN : N -> CN ; --- structural - - only_Predet : Predet ; - this_Quant : Quant ; - } ; diff --git a/lib/resource-1.0/gf/NounEng.gf b/lib/resource-1.0/gf/NounEng.gf index 700ff567d..68de2e676 100644 --- a/lib/resource-1.0/gf/NounEng.gf +++ b/lib/resource-1.0/gf/NounEng.gf @@ -5,8 +5,7 @@ concrete NounEng of Noun = CatEng ** open ResEng in { lin DetCN det cn = {s = \\c => det.s ++ cn.s ! det.n ! c} ** agrP3 det.n ; UsePN pn = pn ** agrP3 Sg ; --- UsePron p = p ; --- causes mcfg error, even if expanded - UsePron2 p = {s=p.s; a={n=p.a.n;p=p.a.p}} ; --- causes mcfg error, even if expanded + UsePron p = p ; MkDet pred quant num = { s = pred.s ++ quant.s ++ num.s ; @@ -30,8 +29,5 @@ concrete NounEng of Noun = CatEng ** open ResEng in { ComplN2 f x = {s = \\n,c => f.s ! n ! Nom ++ f.c2 ++ x.s ! c} ; ComplN3 f x = {s = \\n,c => f.s ! n ! Nom ++ f.c2 ++ x.s ! c ; c2 = f.c3} ; --- structural - - only_Predet = {s = "only"} ; } diff --git a/lib/resource-1.0/gf/Question.gf b/lib/resource-1.0/gf/Question.gf new file mode 100644 index 000000000..db47f0e53 --- /dev/null +++ b/lib/resource-1.0/gf/Question.gf @@ -0,0 +1,17 @@ +abstract Question = Cat, Sentence ** { + + fun + + QuestCl : Cl -> QCl ; + QuestVP : IP -> VP -> QCl ; + QuestSlash : IP -> Slash -> QCl ; + QuestIAdv : IAdv -> Cl -> QCl ; + + PrepIP : Prep -> IP -> IAdv ; + FunIP : N2 -> IP -> IP ; + AdvIP : IP -> Adv -> IP ; + + IDetCN : IDet -> Num -> IP ; + +} + diff --git a/lib/resource-1.0/gf/QuestionEng.gf b/lib/resource-1.0/gf/QuestionEng.gf new file mode 100644 index 000000000..215f19e0d --- /dev/null +++ b/lib/resource-1.0/gf/QuestionEng.gf @@ -0,0 +1,37 @@ +concrete QuestionEng of Question = CatEng, SentenceEng ** open ResEng in { + + lin + + QuestCl cl = { + s = \\t,a,p => + let cls = cl.s ! t ! a ! p + in table { + QDir => cls ! OQuest ; + QIndir => "if" ++ cls ! ODir + } ---- "whether" in exts + } ; + + QuestVP qp vp = { + s = \\t,a,b,q => + let + agr = {n = qp.n ; p = P3} ; + verb = vp.s ! t ! a ! b ! ODir ! agr ; + subj = qp.s ! Nom ; + compl = vp.s2 ! agr + in + subj ++ verb.fin ++ verb.inf ++ compl + } ; + +{- + QuestSlash : IP -> Slash -> QCl ; + QuestIAdv : IAdv -> Cl -> QCl ; + + PrepIP : Prep -> IP -> IAdv ; + FunIP : N2 -> IP -> IP ; + AdvIP : IP -> Adv -> IP ; + + IDetCN : IDet -> Num -> IP ; +-} + +} + diff --git a/lib/resource-1.0/gf/ResEng.gf b/lib/resource-1.0/gf/ResEng.gf index 51ce3247b..75c0258d9 100644 --- a/lib/resource-1.0/gf/ResEng.gf +++ b/lib/resource-1.0/gf/ResEng.gf @@ -36,6 +36,9 @@ resource ResEng = ParamX ** { } } ; + mkIP : (i,me,my : Str) -> Number -> {s : Case => Str ; n : Number} = + \i,me,my,n -> let who = mkNP i me my n P3 in {s = who.s ; n = n} ; + mkNP : (i,me,my : Str) -> Number -> Person -> {s : Case => Str ; a : Agr} = \i,me,my,n,p -> { s = table { diff --git a/lib/resource-1.0/gf/Test.gf b/lib/resource-1.0/gf/Test.gf index f4887015c..dfb43e693 100644 --- a/lib/resource-1.0/gf/Test.gf +++ b/lib/resource-1.0/gf/Test.gf @@ -2,6 +2,7 @@ abstract Test = Noun, Verb, Sentence, + Question, Untensed, -- Tensed, Lex diff --git a/lib/resource-1.0/gf/TestEng.gf b/lib/resource-1.0/gf/TestEng.gf index 6f4af7ea1..b006ebf28 100644 --- a/lib/resource-1.0/gf/TestEng.gf +++ b/lib/resource-1.0/gf/TestEng.gf @@ -2,6 +2,7 @@ concrete TestEng of Test = NounEng, VerbEng, SentenceEng, + QuestionEng, UntensedEng, -- TensedEng, LexEng diff --git a/lib/resource-1.0/gf/Untensed.gf b/lib/resource-1.0/gf/Untensed.gf index 1528e5983..d3e6c08a0 100644 --- a/lib/resource-1.0/gf/Untensed.gf +++ b/lib/resource-1.0/gf/Untensed.gf @@ -1,6 +1,7 @@ abstract Untensed = Cat ** { fun - PosCl, NegCl : Cl -> S ; + PosCl, NegCl : Cl -> S ; + PosQCl, NegQCl : QCl -> QS ; } diff --git a/lib/resource-1.0/gf/UntensedEng.gf b/lib/resource-1.0/gf/UntensedEng.gf index 4ebb195fc..041cf6dfa 100644 --- a/lib/resource-1.0/gf/UntensedEng.gf +++ b/lib/resource-1.0/gf/UntensedEng.gf @@ -6,4 +6,7 @@ concrete UntensedEng of Untensed = CatEng ** open ResEng in { PosCl cl = {s = cl.s ! Pres ! Simul ! Pos ! ODir} ; NegCl cl = {s = cl.s ! Pres ! Simul ! Neg ! ODir} ; + PosQCl cl = {s = cl.s ! Pres ! Simul ! Pos} ; + NegQCl cl = {s = cl.s ! Pres ! Simul ! Neg} ; + } diff --git a/lib/resource-1.0/gf/VerbEng.gf b/lib/resource-1.0/gf/VerbEng.gf index b192125f1..de951c08c 100644 --- a/lib/resource-1.0/gf/VerbEng.gf +++ b/lib/resource-1.0/gf/VerbEng.gf @@ -10,7 +10,7 @@ concrete VerbEng of Verb = CatEng ** open ResEng in { insertObj (\\_ => v.c2 ++ np.s ! Acc ++ v.c3 ++ np2.s ! Acc) (predV v) ; ComplVV v vp = insertObj (\\a => v.c2 ++ infVP vp a) (predV v) ; ComplVS v s = insertObj (\\_ => conjThat ++ s.s) (predV v) ; - ComplVQ v q = insertObj (\\_ => q.s) (predV v) ; + ComplVQ v q = insertObj (\\_ => q.s ! QIndir) (predV v) ; UseComp comp = insertObj comp.s (predAux auxBe) ; AdvVP vp adv = insertObj (\\_ => adv.s) vp ; diff --git a/src/GF/API.hs b/src/GF/API.hs index 7f2d95770..ff199f589 100644 --- a/src/GF/API.hs +++ b/src/GF/API.hs @@ -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 diff --git a/src/GF/API/IOGrammar.hs b/src/GF/API/IOGrammar.hs index ce522a9e5..cb84d9bf7 100644 --- a/src/GF/API/IOGrammar.hs +++ b/src/GF/API/IOGrammar.hs @@ -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 diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs index 16285c44c..09209fa2d 100644 --- a/src/GF/Compile/ShellState.hs +++ b/src/GF/Compile/ShellState.hs @@ -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)] diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs index cdacb7989..d4ead22f7 100644 --- a/src/GF/Shell.hs +++ b/src/GF/Shell.hs @@ -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 diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs index 0649fe7a8..cd54c71ed 100644 --- a/src/GF/Shell/PShell.hs +++ b/src/GF/Shell/PShell.hs @@ -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) diff --git a/src/GF/Shell/ShellCommands.hs b/src/GF/Shell/ShellCommands.hs index 121d8cda6..b9ab2c01b 100644 --- a/src/GF/Shell/ShellCommands.hs +++ b/src/GF/Shell/ShellCommands.hs @@ -50,6 +50,7 @@ data Command = | CGenerateTrees | CPutTerm | CWrapTerm I.Ident + | CApplyTransfer (Maybe I.Ident, I.Ident) | CMorphoAnalyse | CTestTokenizer | CComputeConcrete String