questions and transfer in shell state

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 ;
+
 }

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} ;    
+
 }

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 ;
 }

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 ;
 
 }

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 ;
-
 } ;

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"} ;
 
 }

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 ;
+
+}
+   

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 ;
+-}
+
+}
+   

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 {

lib/resource-1.0/gf/Test.gf

@@ -2,6 +2,7 @@ abstract Test =
   Noun,
   Verb, 
   Sentence, 
+  Question,
   Untensed, 
   -- Tensed,
   Lex 

lib/resource-1.0/gf/TestEng.gf

@@ -2,6 +2,7 @@ concrete TestEng of Test =
   NounEng, 
   VerbEng, 
   SentenceEng,
+  QuestionEng,
   UntensedEng,
   -- TensedEng,
   LexEng 

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 ;
 
 }

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} ;
+
 }

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 ;
 

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

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

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

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

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)

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