Improvements in hte editor.

src/GF/API.hs

@@ -138,11 +138,13 @@ randomTreesIO :: Options -> GFGrammar -> Int -> IO [Tree]
 randomTreesIO opts gr n = do
   gen <- myStdGen mx
   t   <- err (\s -> putStrLnFlush s >> return []) (return . singleton) $ 
-                                                       mkRandomTree gen mx g cat
+                                                       mkRandomTree gen mx g catfun
   ts  <- if n==1 then return [] else randomTreesIO opts gr (n-1)
   return $ t ++ ts
  where
-   cat = firstAbsCat opts gr
+   catfun = case getOptVal opts withFun of
+     Just fun -> Right $ (absId gr, I.identC fun)
+     _ -> Left $ firstAbsCat opts gr
    g   = grammar gr
    mx  = optIntOrN opts flagDepth 41
 
@@ -156,10 +158,18 @@ optLinearizeTreeVal :: Options -> GFGrammar -> Tree -> String
 optLinearizeTreeVal opts gr = err id id . optLinearizeTree opts gr
 
 optLinearizeTree :: Options -> GFGrammar -> Tree -> Err String
-optLinearizeTree opts gr t 
+optLinearizeTree opts gr t = case getOptVal opts markLin of
-  | oElem showRecord opts = liftM prt $ linearizeNoMark g c t
+  Just mk
-  | otherwise             = return $ linTree2string g c t
+    | mk == markOptXML    -> lin markXML t
+    | mk == markOptJava   -> lin markXMLjgf t
+    | mk == markOptStruct -> lin markBracket t
+    | mk == markOptFocus  -> lin markFocus t
+    | otherwise           -> lin noMark t 
+  _ -> lin noMark t
  where
+   lin mk
+    | oElem showRecord opts = liftM prt . linearizeNoMark g c
+    | otherwise             = return . linTree2string mk g c
    g = grammar gr
    c = cncId gr
 

src/GF/CF/CFIdent.hs

@@ -107,6 +107,10 @@ idents2CFCat m c = ident2CFCat (CIQ m c) (identC "s")
 catVarCF :: CFCat
 catVarCF = ident2CFCat (mkCIdent "_" "#Var") (identC "_") ----
 
+cat2CFCat :: (Ident,Ident) -> CFCat
+cat2CFCat = uncurry idents2CFCat
+
+
 {- ----
 uCFCat :: CFCat
 uCFCat = cat2CFCat uCat
@@ -116,9 +120,8 @@ moduleOfCFCat :: CFCat -> Ident
 moduleOfCFCat (CFCat (CIQ m _, _)) = m
 
 -- the opposite direction
-cfCat2Cat :: CFCat -> CIdent   
+cfCat2Cat :: CFCat -> (Ident,Ident)
-cfCat2Cat (CFCat (s,_)) = s
+cfCat2Cat (CFCat (CIQ m c,_)) = (m,c)
-
 
 -- to construct CF tokens
 

src/GF/Canon/CMacros.hs

@@ -3,6 +3,8 @@ module CMacros where
 import AbsGFC
 import GFC
 import qualified Ident as A ---- no need to qualif? 21/9
+import qualified Values as V
+import qualified MMacros as M
 import PrGrammar
 import Str
 
@@ -13,21 +15,53 @@ import Monad
 
 -- macros for concrete syntax in GFC that do not need lookup in a grammar
 
-markFocus :: Term -> Term
+-- how to mark subtrees, dep. on node, position, whether focus
-markFocus = markSubterm "[*" "*]"
+type Marker = V.TrNode -> [Int] -> Bool -> (String, String)
 
-markSubterm :: String -> String -> Term -> Term
+markSubtree :: Marker -> V.TrNode -> [Int] -> Bool -> Term -> Term
-markSubterm beg end t = case t of
+markSubtree mk n is = markSubterm . mk n is
+
+-- if no marking is wanted, use the following
+noMark :: Marker
+noMark _ _ _ = ("","")
+
+-- for vanilla brackets, focus, and position, use
+markBracket :: Marker
+markBracket n p b = if b then ("[*" ++ show p,"*]") else ("[" ++ show p,"]")
+
+-- for focus only
+markFocus :: Marker
+markFocus n p b = if b then ("[*","*]") else ("","")
+
+-- for XML, use
+markXML :: Marker
+markXML n i b = 
+  if b 
+    then ("<focus" +++ p +++ c ++ ">", "</focus>") 
+    else ("<subtree" +++ p +++ c ++ ">", "</subtree>") 
+   where 
+     c = "type=" ++ prt (M.valNode n)
+     p = "position=" ++ show i
+
+-- for XML in JGF 1, use
+markXMLjgf :: Marker
+markXMLjgf n p b = 
+  if b 
+    then ("<focus" +++ c ++ ">", "</focus>") 
+    else ("","")
+   where 
+     c = "type=" ++ prt (M.valNode n)
+
+-- the marking engine
+markSubterm :: (String,String) -> Term -> Term
+markSubterm (beg, end) t = case t of
   R rs -> R $ map markField rs 
   T ty cs -> T ty [Cas p (mark v) | Cas p v <- cs]
   _    -> foldr1 C [tK beg, t, tK end]  -- t : Str guaranteed?
  where
-   mark = markSubterm beg end
+   mark = markSubterm (beg, end)
    markField lt@(Ass l t) = if isLinLabel l then (Ass l (mark t)) else lt
-   isLinLabel (L (A.IC s)) = case s of ----
+   
-      's':cs -> all isDigit cs
-      _ -> False
-
 tK :: String -> Term
 tK = K . KS
 

src/GF/Compile/PGrammar.hs

@@ -43,12 +43,14 @@ string2formsAndTerm s = case s of
       (x,_:y) -> (pTrms (tail x), pTrm y)
       _ -> ([],pTrm s)
     _ -> ([], pTrm s)
+-}
 
 string2ident :: String -> Err Ident
 string2ident s = return $ case s of
   c:'_':i -> identV (readIntArg i,[c]) ---
   _ -> zIdent s
 
+{-
 -- reads the Haskell datatype
 readGrammar :: String -> Err GrammarST
 readGrammar s =  case [x | (x,t) <- reads s, ("","") <- lex t] of

src/GF/Compile/ShellState.hs

@@ -3,8 +3,11 @@ module ShellState where
 import Operations
 import GFC
 import AbsGFC
----import CMacros
+import Macros
+import MMacros
+
 import Look
+import LookAbs
 import qualified Modules as M
 import qualified Grammar as G
 import qualified PrGrammar as P
@@ -108,15 +111,12 @@ updateShellState opts sh (gr,(sgr,rts)) = do
       notInrts f = notElem f $ map fst rts
   cfs <- mapM (canon2cf opts cgr) concrs --- would not need to update all...
 
-  let funs = [] ---- funRulesOf cgr
+  let funs = funRulesOf cgr
-  let cats = [] ---- allCatsOf cgr
+  let cats = allCatsOf cgr
-  let csi  = [] ----
+  let csi  = [(c,(co,
-{-
-             [(c,(co,
                   [(fun,typ) | (fun,typ) <- funs, compatType tc typ], 
                   funsOnTypeFs compatType funs tc))
-                                              | (c,co) <- cats, let tc = cat2type c]
+                                      | (c,co) <- cats, let tc = cat2val co c]
--}
   let deps = True ---- not $ null $ allDepCats cgr
   let binds = [] ---- allCatsWithBind cgr 
 
@@ -163,6 +163,9 @@ greatestAbstract gr = case allAbstracts gr of
   [] -> Nothing
   a -> return $ last a
 
+qualifTop :: StateGrammar -> G.QIdent -> G.QIdent
+qualifTop gr (_,c) = (absId gr,c)
+
 -- all concretes for a given abstract
 allConcretes :: CanonGrammar -> Ident -> [Ident]
 allConcretes gr a = [i | (i,M.ModMod m) <- M.modules gr, M.mtype m== M.MTConcrete a]

src/GF/Fudgets/CommandF.hs

@@ -14,7 +14,7 @@ import EventF
 
 fudlogueEditF :: CEnv -> IO ()
 fudlogueEditF env = 
-  fudlogue $ gfSizeP $ shellF ("GF 1.1 Fudget Editor") (gfF env)
+  fudlogue $ gfSizeP $ shellF ("GF 2.0- Fudget Editor") (gfF env)
 
 gfF env = nameLayoutF gfLayout $ (gfOutputF env >==< gfCommandF env) >+< quitButF
 

src/GF/Grammar/LookAbs.hs

@@ -97,7 +97,6 @@ funsOnTypeFs compat fs val = [((fun,i),typ) |
                                         (i,arg) <- zip [0..] (map snd args),
                                         compat val arg]
 
-
 -- this is needed at compile time
 
 lookupFunTypeSrc :: Grammar -> Ident -> Ident -> Err Type

src/GF/Grammar/MMacros.hs

@@ -231,6 +231,13 @@ fun2wrap oldvars ((fun,i),typ) exp = do
     let vars = mkFreshVars (length cont) oldvars
     return $ mkAbs vars $ if n==i then exp else mExp
 
+-- weak heuristics: sameness of value category
+compatType :: Val -> Type -> Bool
+compatType v t = errVal True $ do
+  cat1 <- val2cat v
+  cat2 <- valCat t
+  return $ cat1 == cat2
+
 ---
 
 mkJustProd cont typ = mkProd (cont,typ,[])

src/GF/Grammar/TypeCheck.hs

@@ -229,3 +229,9 @@ editAsTermCommand gr c e = err (const []) singleton $ do
   t  <- annotate gr $ refreshMetas [] e
   t' <- c $ tree2loc t
   return $ tree2exp $ loc2tree t'
+
+exp2termCommand :: GFCGrammar -> (Exp -> Err Exp) -> Tree -> Err Tree
+exp2termCommand gr f t = do
+  let exp = tree2exp t
+  exp2 <- f exp
+  annotate gr exp2

src/GF/Grammar/Values.hs

@@ -50,3 +50,11 @@ tree2exp (Tr (N (bi,at,_,_,_),ts)) = foldr Abs (foldl App at' ts') bi' where
     AtI s -> EInt s
   bi' = map fst bi
   ts' = map tree2exp ts
+
+loc2treeFocus :: Loc TrNode -> Tree
+loc2treeFocus (Loc (Tr (a,ts),p)) = 
+  loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p)) 
+ where 
+   (mark, nomark) = (\(N (a,b,c,d,_)) -> N(a,b,c,d,True), 
+                     \(N (a,b,c,d,_)) -> N(a,b,c,d,False))
+

src/GF/Infra/Option.hs

@@ -20,6 +20,10 @@ oArg s = s -- value of option argument
 oElem :: Option -> Options -> Bool
 oElem o (Opts os) = elem o os
 
+eqOpt :: String -> Option -> Bool
+eqOpt s (Opt (o, [])) = s == o
+eqOpt s _ = False
+
 type OptFun = String -> Option
 
 getOptVal :: Options -> OptFun -> Maybe String
@@ -164,6 +168,7 @@ absView   = iOpt "Abs"
 useTokenizer   = aOpt "lexer"
 useUntokenizer = aOpt "unlexer"
 useParser      = aOpt "parser"
+withFun        = aOpt "fun"
 firstCat       = aOpt "cat"      -- used on command line
 gStartCat      = aOpt "startcat" -- used in grammar, to avoid clash w res word
 useLanguage    = aOpt "lang"
@@ -182,6 +187,13 @@ noDepTypes     = aOpt "nodeptypes"
 extractGr      = aOpt "extract"
 pathList       = aOpt "path"
 
+markLin        = aOpt "mark"
+markOptXML     = oArg "xml"
+markOptJava    = oArg "java"
+markOptStruct  = oArg "struct"
+markOptFocus   = oArg "focus"
+
+
 -- refinement order
 nextRefine  = aOpt "nextrefine"
 firstRefine = oArg "first"

src/GF/Shell.hs

@@ -143,8 +143,8 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of
   CImport file | oElem showOld opts -> useIOE sa $ batchCompileOld file >> return sa
 
   CImport file -> useIOE sa $ do
-    st <- shellStateFromFiles opts st file
+    st1 <- shellStateFromFiles opts st file
-    ioeIO $ changeState (const st) sa --- \ ((_,h),a) -> ((st,h), a))
+    ioeIO $ changeState (const st1) sa --- \ ((_,h),a) -> ((st,h), a))
   CEmptyState         -> changeState reinitShellState sa
 
 {-

src/GF/Shell/Commands.hs

@@ -9,6 +9,7 @@ import GFC
 import qualified AbsGFC ---- Atom
 import CMacros
 import LookAbs
+import Values (loc2treeFocus)----
 
 import GetTree
 import API
@@ -27,7 +28,7 @@ import Unicode
 
 import Option
 import CF
------ import CFIdent (cat2CFCat, cfCat2Cat)
+import CFIdent (cat2CFCat, cfCat2Cat)
 import Linear
 import Randomized
 import Editing
@@ -114,20 +115,19 @@ initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of
 
 execCommand :: CEnv -> Command -> SState -> IO (CEnv,SState)
 execCommand env c s = case c of
-{- ----
+
 -- these commands do need IO
-  CCEnvImport file -> do
+  CCEnvImport file -> useIOE (env,s) $ do
-
+    st <- shellStateFromFiles opts env file
-    gr <- optFile2grammar noOptions (maybeStateAbstract env) file
+    return (st,s)
-    let lan = getLangNameOpt noOptions file
-    return (updateLanguage file (lan, getStateConcrete gr) 
-                           (initWithAbstract (stateAbstract gr) env), s)
 
+{- ----
   CCEnvEmptyAndImport file -> do
     gr <- optFile2grammar noOptions Nothing file
     let lan = getLangNameOpt noOptions file
     return (updateLanguage file (lan, getStateConcrete gr) 
                  (initWithAbstract (stateAbstract gr) emptyShellState), initSState)
+-}
 
   CCEnvEmpty -> do
     return (emptyShellState, initSState)
@@ -137,6 +137,7 @@ execCommand env c s = case c of
     (msg,(env',_)) <- Shell.execLines False cs (Shell.initHState env)
     return (env', changeMsg msg s) ----
 
+{- ----
   CCEnvOpenTerm file -> do
     c <- readFileIf file
     let (fs,t) = envAndTerm file c
@@ -159,10 +160,11 @@ execCommand env c s = case c of
     state1 <- return $ 
                    refineByExps True gr (parseAny agrs cat t) $ changeState state0 s
     return (env', state1)
-
-  CCEnvOn  name -> return (languageOn  (language name) env,s)
-  CCEnvOff name -> return (languageOff (language name) env,s)
 -}
+
+----  CCEnvOn  name -> return (languageOn  (language name) env,s)
+----  CCEnvOff name -> return (languageOff (language name) env,s)
+
 -- this command is improved by the use of IO
   CRefineRandom -> do
     g <- newStdGen
@@ -196,12 +198,10 @@ execECommand env c = case c of
   CNewCat cat        -> action2commandNext $ \x -> do
                           s' <- newCat cgr cat x
                           uniqueRefinements cgr s'
-{- ----
   CNewTree s         -> action2commandNext $ \x -> do 
                           t  <- string2treeErr gr s 
                           s' <- newTree t x
                           uniqueRefinements cgr s'
--}
   CAhead n           -> action2command (goAheadN n)
   CBack n            -> action2command (goBackN n)
   CTop               -> action2command $ return . goRoot
@@ -215,34 +215,43 @@ execECommand env c = case c of
   CWrapWithFun fi    -> action2commandNext $ wrapWithFun cgr fi
   CChangeHead f      -> action2commandNext $ changeFunHead cgr f
   CPeelHead          -> action2commandNext $ peelFunHead cgr
-{- ----
+
   CAlphaConvert s    -> action2commandNext $ \x ->
-                          string2varPair s >>= \xy -> alphaConvert gr xy x
+                          string2varPair s >>= \xy -> alphaConvert cgr xy x
-
+{- ----
   CRefineWithTree s  -> action2commandNext $ \x -> 
-                          (string2treeErr gr s x >>= \t -> refineWithTree der gr t x)
+                          (string2treeErr cgr s x >>= 
+                            \t -> refineWithTree der cgr t x)
 
-  CRefineParse str   -> \s -> refineByExps der gr 
+  CRefineParse str   -> \s -> refineByTrees der cgr 
                           (parseAny agrs (cat2CFCat (actCat (stateSState s))) str) s
 -}
+  CRefineParse str   -> \s -> 
+                     let cat = cat2CFCat (qualifTop sgr (actCat (stateSState s)))
+                         ts = parseAny agrs cat str
+                     in (if null ts ---- debug
+                           then withMsg [str, "parse failed in cat" +++ show cat]
+                           else id) 
+                            (refineByTrees der cgr ts) s
+
   
-  CRefineRandom -> \s -> action2commandNext
+  CRefineRandom      -> \s -> action2commandNext
-                              (refineRandom (stdGenCEnv env s) 41 cgr) s 
+                                (refineRandom (stdGenCEnv env s) 41 cgr) s 
 
   CSelectCand i      -> selectCand cgr i
-{- ----
+
   CTermCommand c     -> case c of
                           "paraphrase" -> \s ->
-                             replaceByTermCommand gr c (actExp (stateSState s)) s
+                            replaceByTermCommand der gr c (actTree (stateSState s)) s
-                          "transfer" -> action2commandNext $
+----                          "transfer" -> action2commandNext $
-                                        transferSubTree (stateTransferFun sgr) gr
+----                                       transferSubTree (stateTransferFun sgr) gr
                           _ -> replaceByEditCommand gr c
--}
+
 ----  CAddOption o       -> changeStOptions (addOption o)
 ----  CRemoveOption o    -> changeStOptions (removeOption o)
   CDelete            -> action2commandNext $ deleteSubTree cgr
   CUndo              -> undoCommand
-----  CMenu              -> \s -> changeMsg (menuState env s) s
+  CMenu              -> \s -> changeMsg (menuState env s) s
   CView              -> changeView
   CHelp h            -> changeMsg [h env]
   CVoid              -> id
@@ -258,18 +267,16 @@ execECommand env c = case c of
 --
 
 
-{- ----
 string2varPair :: String -> Err (I.Ident,I.Ident)
 string2varPair s = case words s of
   x : y : [] -> liftM2 (,) (string2ident x) (string2ident y)
   _          -> Bad "expected format 'x y'"
 
-
 -- seen on display
 
 cMenuDisplay :: String -> Command
 cMenuDisplay s = CAddOption (menuDisplay s)
--}
+
 newCatMenu env = [(CNewCat c, prQIdent c) | ---- printname env initSState c) | 
                          (c,[]) <- allCatsOf (canCEnv env)]
 
@@ -282,7 +289,7 @@ mkRefineMenuAll env sstate =
     ([],[],wraps) -> 
        [(CWrapWithFun fi, prWrap fit)     | fit@(fi,_) <- wraps] ++
        [(CChangeHead f,   prChangeHead f) | f <- headChangesState cgr state] ++
-       [(CPeelHead,     (ifShort "ph" "PeelHead", "ph")) | canPeelState cgr state] ++
+       [(CPeelHead,    (ifShort "ph" "PeelHead", "ph")) | canPeelState cgr state] ++
        [(CDelete,       (ifShort "d"  "Delete",   "d"))]
     (refs,[],_)   -> [(CRefineWithAtom (prRefinement f), prRef t) | t@(f,_) <- refs]
     (_,cands,_)   -> [(CSelectCand i,   prCand (t,i))    | (t,i) <- zip cands [0..]]
@@ -327,14 +334,17 @@ emptyMenuItem = (CVoid,("",""))
 
 ---- allStringCommands = snd $ customInfo customStringCommand
 termCommandMenu, stringCommandMenu :: [(Command,String)]
-termCommandMenu = []
+termCommandMenu = [(CTermCommand s, s) | s <- allTermCommands]
+
+allTermCommands = snd $ customInfo customEditCommand
+
 stringCommandMenu = []
 
 displayCommandMenu :: CEnv -> [(Command,String)]
 displayCommandMenu env = []
 {- ----
----- allTermCommands = snd $ customInfo customEditCommand
+
-termCommandMenu = [(CTermCommand s, s) | s <- allTermCommands]
+termCommandMenu = 
 
 stringCommandMenu = 
    (CAddOption showStruct,      "structured") :
@@ -367,7 +377,8 @@ displaySStateIn env state = (tree',msg,menu) where
   grs    = allStateGrammars env
   lang   = (viewSState state) `mod` (length grs + 3)
   tree'  = (tree : exp : linAll ++ separ (linAll ++ [tree])) !! lang
-  opts   = addOptions (optsSState state) (globalOptions env)  -- state opts override
+  opts   = addOptions (optsSState state)   -- state opts override
+             (addOption (markLin markOptFocus) (globalOptions env))
   lin g  = linearizeState fudWrap opts g zipper
   exp    = return $ tree2string $ loc2tree zipper
   zipper = stateSState state
@@ -387,7 +398,8 @@ displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [
   (ls,grs) = unzip $ lgrs
   lgrs   = allStateGrammarsWithNames env --- allActiveStateGrammarsWithNames env
   lins   = (langAbstract, exp) : linAll
-  opts   = addOptions (optsSState state) (globalOptions env)  -- state opts override
+  opts   = addOptions (optsSState state)   -- state opts override 
+              (addOption (markLin markOptJava) (globalOptions env))
   lin (n,gr) = (n, map uni $ linearizeState noWrap opts gr zipper) where
                   uni = optEncodeUTF8 n gr . mkUnicode
   exp    = prprTree $ loc2tree zipper
@@ -402,7 +414,7 @@ langXML      = language "XML"
 
 linearizeState :: (String -> [String]) -> Options -> GFGrammar -> State -> [String]
 linearizeState wrap opts gr = 
- wrap . strop . unt . optLinearizeTreeVal opts gr . loc2tree
+ wrap . strop . unt . optLinearizeTreeVal opts gr . loc2treeFocus
                   --- markedLinString br g
   where
    unt   = id ---- customOrDefault (stateOptions g) useUntokenizer customUntokenizer g

src/GF/UseGrammar/Custom.hs

@@ -3,6 +3,7 @@ module Custom where
 import Operations
 import Text
 import Tokenize
+import Values
 import qualified Grammar as G
 import qualified AbsGFC as A
 import qualified GFC as C
@@ -22,6 +23,8 @@ import CFIdent
 import PPrCF
 import PrGrammar
 
+import Zipper
+
 ----import Morphology
 -----import GrammarToHaskell
 -----import GrammarToCanon (showCanon, showCanonOpt)
@@ -34,6 +37,8 @@ import MoreCustom -- either small/ or big/. The one in Small is empty.
 
 import UseIO
 
+import Monad
+
 -- minimal version also used in Hugs. AR 2/12/2002. 
 
 -- databases for customizable commands. AR 21/11/2001
@@ -59,10 +64,10 @@ customGrammarPrinter :: CustomData (StateGrammar -> String)
 customSyntaxPrinter  :: CustomData (GF.Grammar -> String)        
 
 -- termPrinter, "-printer=x"
-customTermPrinter  :: CustomData (StateGrammar -> A.Exp -> String)
+customTermPrinter  :: CustomData (StateGrammar -> Tree -> String)
 
 -- termCommand, "-transform=x"
-customTermCommand    :: CustomData (StateGrammar -> A.Exp -> [A.Exp])
+customTermCommand    :: CustomData (StateGrammar -> Tree -> [Tree])
 
 -- editCommand, "-edit=x"
 customEditCommand    :: CustomData (StateGrammar -> Action)
@@ -172,15 +177,15 @@ customTermCommand =
   customData "Term transformers, selected by option -transform=x" $
   [
    (strCI "identity",   \_ t -> [t]) -- DEFAULT
-{- ----
+  ,(strCI "compute",    \g t -> let gr = grammar g in
-  ,(strCI "compute",    \g t -> err (const [t]) return (computeAbsTerm g t))
+                                  err (const [t]) return 
-  ,(strCI "paraphrase", \g t -> mkParaphrases g t)
+                                    (exp2termCommand gr (computeAbsTerm gr) t))
-  ,(strCI "typecheck",  \g t -> err (const []) return (checkIfValidExp g t))
+----  ,(strCI "paraphrase", \g t -> mkParaphrases g t)
-  ,(strCI "solve",      \g t -> editAsTermCommand g 
+----  ,(strCI "typecheck",  \g t -> err (const []) return (checkIfValidExp g t))
-                                            (uniqueRefinements g) t)
+  ,(strCI "solve",      \g t -> err (const [t]) (return . loc2tree)
-  ,(strCI "context",    \g t -> editAsTermCommand g  
+                                   (uniqueRefinements (grammar g) (tree2loc t)))
-                                            (contextRefinements g) t)
+  ,(strCI "context",    \g t -> err (const [t]) (return . loc2tree)
--}
+                                   (contextRefinements (grammar g) (tree2loc t)))
 ---  ,(strCI "delete",     \g t -> [MM.mExp0])
 -- add your own term commands here
   ]
@@ -191,12 +196,10 @@ customEditCommand =
   [
    (strCI "identity",   const return) -- DEFAULT
   ,(strCI "transfer",   const return) --- done ad hoc on top level
-{- ----
+  ,(strCI "typecheck",  \g -> reCheckState (grammar g))
-  ,(strCI "typecheck",  reCheckState)
+  ,(strCI "solve",      \g -> solveAll (grammar g))
-  ,(strCI "solve",      solveAll)
+  ,(strCI "context",    \g -> contextRefinements (grammar g))
-  ,(strCI "context",    contextRefinements)
+  ,(strCI "compute",    \g -> computeSubTree (grammar g))
-  ,(strCI "compute",    computeSubTree)
--}
   ,(strCI "paraphrase", const return) --- done ad hoc on top level
 -- add your own edit commands here
   ]

src/GF/UseGrammar/Editing.hs

@@ -129,6 +129,13 @@ newCat gr cat@(m,c) _ = do
   testErr (null cont) "start cat must have null context" -- for easier meta refresh
   initStateCat cont cat
 
+newFun :: CGrammar -> Fun -> Action
+newFun gr fun@(m,c) _ = do
+  typ <- lookupFunType gr m c
+  cat <- valCat typ
+  st1 <- newCat gr cat initState
+  refineWithAtom True gr (qq fun) st1
+
 newTree :: Tree -> Action
 newTree t _ = return $ tree2loc t
 

src/GF/UseGrammar/Linear.hs

@@ -24,19 +24,17 @@ import Monad
 
 -- NB. Constants in trees are annotated by the name of the abstract module.
 -- A concrete module name must be given to find (and choose) linearization rules.
+-- If no marking is wanted, noMark  :: Marker.
+-- For xml marking, use     markXML :: Marker
 
 linearizeToRecord :: CanonGrammar -> Marker -> Ident -> A.Tree -> Err Term
 linearizeToRecord gr mk m = lin [] where
 
-  lin ts t = errIn ("lint" +++ prt t) $ ---- 
+  lin ts t@(Tr (n,xs)) = errIn ("linearization of" +++ prt t) $ do
-    if A.isFocusNode (A.nodeTree t) 
-      then liftM markFocus $ lint ts t
-      else lint ts t
-
-  lint ts t@(Tr (n,xs)) = do
 
     let binds = A.bindsNode n
         at    = A.atomNode n
+        fmk   = markSubtree mk n ts (A.isFocusNode n)
     c   <- A.val2cat $ A.valNode n
     xs' <- mapM (\ (i,x) -> lin (i:ts) x) $ zip [0..] xs
 
@@ -47,7 +45,7 @@ linearizeToRecord gr mk m = lin [] where
       A.AtV x -> lookCat c >>= comp [tK (prt at)]
       A.AtM m -> lookCat c >>= comp [tK (prt at)] 
 
-    return $ mk ts $ mkBinds binds r
+    return $ fmk $ mkBinds binds r
 
   look = lookupLin gr . redirectIdent m . rtQIdent
   comp = ccompute gr
@@ -59,12 +57,6 @@ linearizeToRecord gr mk m = lin [] where
   lookCat = return . errVal defLindef . look 
          ---- should always be given in the module
 
-type Marker = [Int] -> Term -> Term
-
--- if no marking is wanted, use the following
-
-noMark :: [Int] -> Term -> Term
-noMark = const id
 
 -- thus the special case:
 
@@ -115,9 +107,9 @@ strs2strings :: [[Str]] -> [String]
 strs2strings = map unlex
 
 -- finally, a top-level function to get a string from an expression
-linTree2string :: CanonGrammar -> Ident -> A.Tree -> String
+linTree2string :: Marker -> CanonGrammar -> Ident -> A.Tree -> String
-linTree2string gr m e = err id id $ do
+linTree2string mk gr m e = err id id $ do
-  t  <- linearizeNoMark gr m e
+  t  <- linearizeToRecord gr mk m e
   r  <- expandLinTables gr t
   ts <- rec2strTables r
   let ss = strs2strings $ sTables2strs $ strTables2sTables ts

src/GF/UseGrammar/Randomized.hs

@@ -15,16 +15,18 @@ import Random --- (mkStdGen, StdGen, randoms) --- bad import for hbc
 myStdGen = mkStdGen ---
 
 -- build one random tree; use mx to prevent infinite search
-mkRandomTree :: StdGen -> Int -> CGrammar -> QIdent -> Err Tree
+mkRandomTree :: StdGen -> Int -> CGrammar -> Either Cat Fun -> Err Tree
 mkRandomTree gen mx gr cat = mkTreeFromInts (take mx (randoms gen)) gr cat
 
 refineRandom :: StdGen -> Int -> CGrammar -> Action
 refineRandom gen mx = mkStateFromInts $ take mx $ map abs (randoms gen)
 
 -- build a tree from a list of integers
-mkTreeFromInts :: [Int] -> CGrammar -> QIdent -> Err Tree
+mkTreeFromInts :: [Int] -> CGrammar -> Either Cat Fun -> Err Tree
-mkTreeFromInts ints gr cat = do
+mkTreeFromInts ints gr catfun = do
-  st0   <- newCat gr cat initState
+  st0   <- either (\cat -> newCat gr cat initState)
+                  (\fun -> newFun gr fun initState)
+                  catfun
   state <- mkStateFromInts ints gr st0
   return $ loc2tree state
 

src/GF/UseGrammar/Session.hs

@@ -2,8 +2,9 @@ module Session where
 
 import Abstract
 import Option
----- import Custom
+import Custom
 import Editing
+import ShellState ---- grammar
 
 import Operations
 
@@ -50,6 +51,9 @@ changeMsg m ((s,ts,(_,b)):ss) = (s,ts,(m,b)) : ss   -- just change message
 changeView :: ECommand
 changeView ((s,ts,(m,(v,b))):ss) = (s,ts,(m,(v+1,b))) : ss    -- toggle view
 
+withMsg :: [String] -> ECommand -> ECommand
+withMsg m c = changeMsg m . c
+
 changeStOptions :: (Options -> Options) -> ECommand
 changeStOptions f ((s,ts,(m,(v,o))):ss) = (s,ts,(m,(v, f o))) : ss
 
@@ -90,21 +94,25 @@ refineByExps der gr trees = case trees of
   [t] -> action2commandNext (refineWithExpTC der gr t)
   _  -> changeCands trees
 
+refineByTrees :: Bool -> CGrammar -> [Tree] -> ECommand
+refineByTrees der gr trees = case trees of
+  [t] -> action2commandNext (refineWithTree der gr t)
+  _  -> changeCands  $ map tree2exp trees
+
 replaceByTrees :: CGrammar -> [Exp] -> ECommand
 replaceByTrees gr trees = case trees of
   [t] -> action2commandNext (\s -> 
             annotateExpInState gr t s >>= flip replaceSubTree s)
   _  -> changeCands trees
 
-{- ----
+replaceByEditCommand :: StateGrammar -> String -> ECommand
-replaceByEditCommand :: CGrammar -> String -> ECommand
 replaceByEditCommand gr co = 
   action2command $
   maybe return ($ gr) $
   lookupCustom customEditCommand (strCI co) 
 
-replaceByTermCommand :: CGrammar -> String -> Exp -> ECommand
+replaceByTermCommand :: Bool -> StateGrammar -> String -> Tree -> ECommand ----
-replaceByTermCommand gr co exp = 
+replaceByTermCommand der gr co exp = 
-  replaceByTrees gr $ maybe [exp] (\f -> f (abstractOf gr) exp) $ 
+  let g = grammar gr in
-    lookupCustom customTermCommand (strCI co) 
+    refineByTrees der g $ maybe [exp] (\f -> f gr exp) $
--}
+      lookupCustom customTermCommand (strCI co)

src/Today.hs

@@ -1 +1 @@
-module Today where today = "Mon Sep 22 15:54:44 CEST 2003"
+module Today where today = "Wed Sep 24 17:15:34 CEST 2003"