Improvements in hte editor.

5 files changed, 57 insertions, 45 deletions

diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index bf84d776b..1048aab95 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/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 -> err (const [t]) return (computeAbsTerm g t))
-  ,(strCI "paraphrase", \g t -> mkParaphrases g t)
-  ,(strCI "typecheck",  \g t -> err (const []) return (checkIfValidExp g t))
-  ,(strCI "solve",      \g t -> editAsTermCommand g 
-                                            (uniqueRefinements g) t)
-  ,(strCI "context",    \g t -> editAsTermCommand g  
-                                            (contextRefinements g) t)
--}
+  ,(strCI "compute",    \g t -> let gr = grammar g in
+                                  err (const [t]) return 
+                                    (exp2termCommand gr (computeAbsTerm gr) t))
+----  ,(strCI "paraphrase", \g t -> mkParaphrases g t)
+----  ,(strCI "typecheck",  \g t -> err (const []) return (checkIfValidExp g t))
+  ,(strCI "solve",      \g t -> err (const [t]) (return . loc2tree)
+                                   (uniqueRefinements (grammar g) (tree2loc 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",  reCheckState)
-  ,(strCI "solve",      solveAll)
-  ,(strCI "context",    contextRefinements)
-  ,(strCI "compute",    computeSubTree)
--}
+  ,(strCI "typecheck",  \g -> reCheckState (grammar g))
+  ,(strCI "solve",      \g -> solveAll (grammar g))
+  ,(strCI "context",    \g -> contextRefinements (grammar g))
+  ,(strCI "compute",    \g -> computeSubTree (grammar g))
   ,(strCI "paraphrase", const return) --- done ad hoc on top level
 -- add your own edit commands here
   ]
diff --git a/src/GF/UseGrammar/Editing.hs b/src/GF/UseGrammar/Editing.hs
index 616ddc7cc..93038e9a0 100644
--- a/src/GF/UseGrammar/Editing.hs
+++ b/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
 
diff --git a/src/GF/UseGrammar/Linear.hs b/src/GF/UseGrammar/Linear.hs
index da1bfce52..9cf391393 100644
--- a/src/GF/UseGrammar/Linear.hs
+++ b/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) $ ---- 
-    if A.isFocusNode (A.nodeTree t) 
-      then liftM markFocus $ lint ts t
-      else lint ts t
-
-  lint ts t@(Tr (n,xs)) = do
+  lin ts t@(Tr (n,xs)) = errIn ("linearization of" +++ prt t) $ 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 gr m e = err id id $ do
-  t  <- linearizeNoMark gr m e
+linTree2string :: Marker -> CanonGrammar -> Ident -> A.Tree -> String
+linTree2string mk gr m e = err id id $ do
+  t  <- linearizeToRecord gr mk m e
   r  <- expandLinTables gr t
   ts <- rec2strTables r
   let ss = strs2strings $ sTables2strs $ strTables2sTables ts
diff --git a/src/GF/UseGrammar/Randomized.hs b/src/GF/UseGrammar/Randomized.hs
index dceb6acc6..a347560a0 100644
--- a/src/GF/UseGrammar/Randomized.hs
+++ b/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 ints gr cat = do
-  st0   <- newCat gr cat initState
+mkTreeFromInts :: [Int] -> CGrammar -> Either Cat Fun -> Err Tree
+mkTreeFromInts ints gr catfun = do
+  st0   <- either (\cat -> newCat gr cat initState)
+                  (\fun -> newFun gr fun initState)
+                  catfun
   state <- mkStateFromInts ints gr st0
   return $ loc2tree state
 
diff --git a/src/GF/UseGrammar/Session.hs b/src/GF/UseGrammar/Session.hs
index bf2dd30ab..051630149 100644
--- a/src/GF/UseGrammar/Session.hs
+++ b/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 :: CGrammar -> String -> ECommand
+replaceByEditCommand :: StateGrammar -> String -> ECommand
 replaceByEditCommand gr co = 
   action2command $
   maybe return ($ gr) $
   lookupCustom customEditCommand (strCI co) 
 
-replaceByTermCommand :: CGrammar -> String -> Exp -> ECommand
-replaceByTermCommand gr co exp = 
-  replaceByTrees gr $ maybe [exp] (\f -> f (abstractOf gr) exp) $ 
-    lookupCustom customTermCommand (strCI co) 
--}
+replaceByTermCommand :: Bool -> StateGrammar -> String -> Tree -> ECommand ----
+replaceByTermCommand der gr co exp = 
+  let g = grammar gr in
+    refineByTrees der g $ maybe [exp] (\f -> f gr exp) $
+      lookupCustom customTermCommand (strCI co)