summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/GF/Shell/CommandL.hs2
-rw-r--r--src/GF/Shell/Commands.hs29
-rw-r--r--src/GF/UseGrammar/Editing.hs8
-rw-r--r--src/GF/UseGrammar/Session.hs31
-rw-r--r--src/Today.hs2
5 files changed, 61 insertions, 11 deletions
diff --git a/src/GF/Shell/CommandL.hs b/src/GF/Shell/CommandL.hs
index d470130ab..dcf62d44b 100644
--- a/src/GF/Shell/CommandL.hs
+++ b/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
diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs
index 3169582e0..649afb682 100644
--- a/src/GF/Shell/Commands.hs
+++ b/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
diff --git a/src/GF/UseGrammar/Editing.hs b/src/GF/UseGrammar/Editing.hs
index cd9fec9a4..3c3567394 100644
--- a/src/GF/UseGrammar/Editing.hs
+++ b/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
+
diff --git a/src/GF/UseGrammar/Session.hs b/src/GF/UseGrammar/Session.hs
index 81158a515..7d43ea33c 100644
--- a/src/GF/UseGrammar/Session.hs
+++ b/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
diff --git a/src/Today.hs b/src/Today.hs
index 923866d3b..8663db727 100644
--- a/src/Today.hs
+++ b/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"
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 19:17:08 +0000