Added clipboard.

src/GF/Shell/CommandL.hs

@@ -55,6 +55,7 @@ pCommand = pCommandWords . words where
     "t" : ws      -> CNewTree $ unwords ws
     "g" : ws      -> CRefineWithTree $ unwords ws  -- *g*ive
     "p" : ws      -> CRefineParse $ unwords ws
+    "rc": i : _   -> CRefineWithClip (readIntArg i)
     ">" : i : _   -> CAhead $ readIntArg i
     ">" : []      -> CAhead 1
     "<" : i : _   -> CBack $ readIntArg i
@@ -75,6 +76,7 @@ pCommand = pCommandWords . words where
     "f" : s : _   -> CAddOption (filterString s)
     "u" : _       -> CUndo
     "d" : _       -> CDelete
+    "ac" : _      -> CAddClip
     "c" : s : _   -> CTermCommand s
     "a" : _       -> CRefineRandom --- *a*leatoire
     "m" :  _      -> CMenu

src/GF/Shell/Commands.hs

@@ -56,6 +56,7 @@ data Command =
  | CLast
  | CMovePosition [Int]
  | CRefineWithTree String
+ | CRefineWithClip Int
  | CRefineWithAtom String
  | CRefineParse String
  | CWrapWithFun (G.Fun,Int)
@@ -68,6 +69,7 @@ data Command =
  | CAddOption Option
  | CRemoveOption Option
  | CDelete
+ | CAddClip
  | CUndo
  | CView
  | CMenu
@@ -226,6 +228,11 @@ execECommand env c = case c of
   CRefineWithTree s  -> action2commandNext $ \x -> 
                           (string2treeInState gr s x >>= 
                             \t -> refineWithTree der cgr t x)
+  CRefineWithClip i  -> \s -> 
+                          let et = getNumberedClip i s
+                          in (case et of 
+                                Ok t -> refineByTrees der cgr [t] s
+                                Bad m -> changeMsg [m] s)
 
   CRefineParse str   -> \s -> 
                      let cat = cat2CFCat (qualifTop sgr (actCat (stateSState s)))
@@ -250,6 +257,7 @@ execECommand env c = case c of
   CAddOption o       -> changeStOptions (addOption o)
   CRemoveOption o    -> changeStOptions (removeOption o)
   CDelete            -> action2commandNext $ deleteSubTree cgr
+  CAddClip           -> \s -> (addtoClip (actTree (stateSState s))) s
   CUndo              -> undoCommand
   CMenu              -> \s -> changeMsg (menuState env s) s
   CView              -> changeView
@@ -290,14 +298,22 @@ mkRefineMenuAll env sstate =
        [(CWrapWithFun fi, prWrap fit)     | fit@(fi,_) <- wraps] ++
        [(CChangeHead f,   prChangeHead f) | f <- headChangesState 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..]]
+       [(CDelete,      (ifShort "d"  "Delete",   "d"))] ++
+       [(CAddClip,     (ifShort "ac" "AddClip",  "ac"))]
+    (refs,[],_)   -> 
+       [(CRefineWithAtom (prRefinement f), prRef t) | t@(f,_) <- refs] ++
+       [(CRefineWithClip i, prClip i t e) | (i,t) <- possClipsSState gr sstate, 
+                                            let e = tree2string t]
+    (_,cands,_)   -> 
+       [(CSelectCand i,   prCand (t,i))    | (t,i) <- zip cands [0..]]
 
  where
-  prRef  (f,t) = 
+  prRef (f,t) = 
     (ifShort "r" "Refine" +++ prOrLinRef f +++ ifTyped (":" +++ prt t),
      "r" +++ prRefinement f)
+  prClip i t e =
+    (ifShort "rc" "Paste" +++ prOrLinTree t e,
+     "rc" +++ show i)
   prChangeHead f = 
     (ifShort "ch" "ChangeHead" +++ prOrLinFun f,
      "ch" +++ prQIdent f)
@@ -323,6 +339,11 @@ mkRefineMenuAll env sstate =
     G.QC m f ->  printname env sstate (m,f) 
     _ -> prt t
   prOrLinFun = printname env sstate
+  prOrLinTree t e = case getOptVal opts menuDisplay of
+    Just "Abs" -> e
+    Just lang  -> prQuotedString $ lin lang t
+    _ -> e
+  lin lang t = optLinearizeTreeVal opts (stateGrammarOfLang env (language lang)) t
 
 -- there are three orthogonal parameters: Abs/[conc], short/long, typed/untyped
 -- the default is Abs, long, untyped; the Menus menu changes the parameter

src/GF/UseGrammar/Editing.hs

@@ -375,3 +375,11 @@ possibleRefVal gr state val typ = errVal True $ do --- was False
   cs   <- return [(val, vClos vtyp)] --- eqVal gen val (vClos vtyp) --- only poss cs
   return $ possibleConstraints gr cs --- a simple heuristic
 
+possibleTreeVal :: CGrammar -> State -> Tree -> Bool
+possibleTreeVal gr state tree = errVal True $ do --- was False
+  let aval = actVal state
+  let gval = valTree tree
+  let gen = actGen state
+  cs  <- return [(aval, gval)] --- eqVal gen val (vClos vtyp) --- only poss cs
+  return $ possibleConstraints gr cs --- a simple heuristic
+

src/GF/UseGrammar/Session.hs

@@ -13,17 +13,20 @@ import Operations
 
 -- keep these abstract
 
-type SState = [(State,[Exp],SInfo)]       -- exps are candidate refinements
-type SInfo  = ([String],(Int,Options))    -- string is message, int is the view
+type SState = [(State,([Exp],[Clip]),SInfo)] -- exps: candidate refinements,clipboard
+type SInfo  = ([String],(Int,Options))       -- string is message, int is the view
 
 initSState :: SState
-initSState = [(initState, [], (["Select category to start"],(0,noOptions)))] 
+initSState = [(initState, ([],[]), (["Select category to start"],(0,noOptions)))] 
              -- instead of empty
 
+type Clip = Tree ---- (Exp,Type)
+
 okInfo n = ([],(n,True))
 
 stateSState ((s,_,_):_)     = s
-candsSState ((_,ts,_):_)    = ts
+candsSState ((_,(ts,_),_):_)= ts
+clipSState  ((_,(_,ts),_):_)= ts
 infoSState  ((_,_,i):_)     = i
 msgSState   ((_,_,(m,_)):_) = m
 viewSState  ((_,_,(_,(v,_))):_) = v
@@ -40,10 +43,13 @@ type ECommand = SState -> SState
 
 -- change state, drop cands, drop message, preserve options
 changeState :: State -> ECommand
-changeState s ss = changeMsg [] $ (s,[],infoSState ss) : ss 
+changeState s ss = changeMsg [] $ (s,([],clipSState ss),infoSState ss) : ss 
 
 changeCands :: [Exp] -> ECommand
-changeCands ts ss@((s,_,(_,b)):_) = (s,ts,(candInfo ts,b)) : ss   -- add new state
+changeCands ts ss@((s,(_,cb),(_,b)):_) = (s,(ts,cb),(candInfo ts,b)) : ss   
+
+addtoClip :: Clip -> ECommand
+addtoClip t ss@((s,(ts,cb),(i,b)):_) = (s,(ts,t:cb),(i,b)) : ss   
 
 changeMsg :: [String] -> ECommand
 changeMsg m ((s,ts,(_,b)):ss) = (s,ts,(m,b)) : ss   -- just change message
@@ -116,3 +122,16 @@ replaceByTermCommand der gr co exp =
   let g = grammar gr in
     refineByTrees der g $ maybe [exp] (\f -> f gr exp) $
       lookupCustom customTermCommand (strCI co)
+
+possClipsSState :: StateGrammar -> SState -> [(Int,Clip)]
+possClipsSState gr s = filter poss $ zip [0..] (clipSState s) 
+ where
+  poss = possibleTreeVal cgr st . snd
+  st   = stateSState s
+  cgr  = grammar gr
+
+getNumberedClip :: Int -> SState -> Err Clip
+getNumberedClip i s = if length cs > i then return (cs !! i) 
+                         else Bad "not enough clips"
+  where
+   cs = clipSState s

src/Today.hs

@@ -1 +1 @@
-module Today where today = "Thu Oct  9 17:52:24 CEST 2003"
+module Today where today = "Fri Oct 10 14:16:56 CEST 2003"