mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-12 06:19:33 -06:00
135 lines
4.0 KiB
Haskell
135 lines
4.0 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : CommandF
|
|
-- Maintainer : AR
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/04/21 16:22:15 $
|
|
-- > CVS $Author: bringert $
|
|
-- > CVS $Revision: 1.6 $
|
|
--
|
|
-- a graphical shell for any kind of GF with Zipper editing. AR 20\/8\/2001
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Fudgets.CommandF where
|
|
|
|
import GF.Data.Operations
|
|
|
|
import GF.UseGrammar.Session
|
|
import GF.Shell.Commands
|
|
|
|
import Fudgets
|
|
import GF.Fudgets.FudgetOps
|
|
|
|
import GF.Fudgets.EventF
|
|
|
|
-- a graphical shell for any kind of GF with Zipper editing. AR 20/8/2001
|
|
|
|
fudlogueEditF :: CEnv -> IO ()
|
|
fudlogueEditF env =
|
|
fudlogue $ gfSizeP $ shellF ("GF 2.0- Fudget Editor") (gfF env)
|
|
|
|
gfF env = nameLayoutF gfLayout $ (gfOutputF env >==< gfCommandF env) >+< quitButF
|
|
|
|
( quitN : menusN : newN : transformN : filterN : displayN :
|
|
navigateN : viewN : outputN : saveN : _) = map show [1..]
|
|
|
|
gfLayout = placeNL verticalP [generics,output,navigate,menus,transform]
|
|
where
|
|
generics = placeNL horizontalP (map leafNL
|
|
[newN,saveN,viewN,displayN,filterN,quitN])
|
|
output = leafNL outputN
|
|
navigate = leafNL navigateN
|
|
menus = leafNL menusN
|
|
transform = leafNL transformN
|
|
|
|
gfSizeP = spacerF (sizeS (Point 720 640))
|
|
|
|
gfOutputF env =
|
|
((nameF outputN $ (writeFileF >+< textWindowF))
|
|
>==<
|
|
(absF (saveSP "EMPTY")
|
|
>==<
|
|
(nameF saveN (popupStringInputF "Save" "foo.tmp" "Save to file:")
|
|
>+<
|
|
mapF (displayJustStateIn env))))
|
|
>==<
|
|
mapF Right
|
|
|
|
gfCommandF :: CEnv -> F () SState
|
|
gfCommandF env = loopCommandsF env >==< getCommandsF env >==< mapF (\_ -> Click)
|
|
|
|
loopCommandsF :: CEnv -> F Command SState
|
|
loopCommandsF env = loopThroughRightF (mapGfStateF env) (mkMenusF env)
|
|
|
|
mapGfStateF :: CEnv -> F (Either Command Command) (Either SState SState)
|
|
mapGfStateF env = mapstateF execFC (initSState) where
|
|
execFC e0 (Left c) = (e,[Right e,Left e]) where e = execECommand env c e0
|
|
execFC e0 (Right c) = (e,[Left e,Right e]) where e = execECommand env c e0
|
|
|
|
mkMenusF :: CEnv -> F SState Command
|
|
mkMenusF env =
|
|
nameF menusN $
|
|
labAboveF "Select Action on Subterm"
|
|
(mapF fst >==< smallPickListF snd >==< mapF (mkRefineMenu env))
|
|
|
|
getCommandsF env =
|
|
newF env >*<
|
|
viewF >*<
|
|
menuDisplayF env >*<
|
|
filterF >*<
|
|
navigateF >*<
|
|
transformF
|
|
|
|
key2command ((key,_),_) = case key of
|
|
"Up" -> CBack 1
|
|
"Down" -> CAhead 1
|
|
"Left" -> CPrevMeta
|
|
"Right" -> CNextMeta
|
|
"space" -> CTop
|
|
|
|
"d" -> CDelete
|
|
"u" -> CUndo
|
|
"v" -> CView
|
|
|
|
_ -> CVoid
|
|
|
|
transformF =
|
|
nameF transformN $
|
|
mapF (either key2command id) >==< (keyboardF $
|
|
placerF horizontalP $
|
|
cPopupStringInputF CRefineParse "Parse" "" "Parse in concrete syntax" >*<
|
|
--- to enable Unicode: ("Refine by parsing" `labLeftOfF` writeInputF)
|
|
cPopupStringInputF CRefineWithTree "Term" "" "Parse term" >*<
|
|
cMenuF "Modify" termCommandMenu >*<
|
|
cPopupStringInputF CAlphaConvert "Alpha" "x_0 x" "Alpha convert" >*<
|
|
cButtonF CRefineRandom "Random" >*<
|
|
cButtonF CUndo "Undo"
|
|
)
|
|
|
|
quitButF = nameF quitN $ quitF >==< buttonF "Quit"
|
|
|
|
newF env = nameF newN $ cMenuF "New" (newCatMenu env)
|
|
menuDisplayF env = nameF displayN $ cMenuF "Menus" $ displayCommandMenu env
|
|
filterF = nameF filterN $ cMenuF "Filter" stringCommandMenu
|
|
|
|
viewF = nameF viewN $ cButtonF CView "View"
|
|
|
|
navigateF =
|
|
nameF navigateN $
|
|
placerF horizontalP $
|
|
cButtonF CPrevMeta "?<" >*<
|
|
cButtonF (CBack 1) "<" >*<
|
|
cButtonF CTop "Top" >*<
|
|
cButtonF CLast "Last" >*<
|
|
cButtonF (CAhead 1) ">" >*<
|
|
cButtonF CNextMeta ">?"
|
|
|
|
cButtonF c s = mapF (const c) >==< buttonF s
|
|
cMenuF s css = menuF s css >==< mapF (\_ -> CVoid)
|
|
|
|
cPopupStringInputF comm lab def msg =
|
|
mapF comm >==< popupStringInputF lab def msg >==< mapF (const [])
|
|
|